WIP: link to compiler sources

doc/create.txt

@@ -18,6 +18,9 @@ DESCRIPTION
 
        Github pull request (short form)
            #number (repo defaults to "ocaml/ocaml")
+
+       Directory
+           path/to/sources
 ARGUMENTS
        SOURCE (required)
            Where to fetch the compiler.

doc/dune

@@ -17,3 +17,13 @@
  (alias runtest)
  (action
   (diff create.txt create.txt.gen)))
+
+(rule
+ (with-stdout-to
+  reinstall.txt.gen
+  (run opam-compiler reinstall --help=plain)))
+
+(rule
+ (alias runtest)
+ (action
+  (diff reinstall.txt reinstall.txt.gen)))

doc/opam-compiler.txt

@@ -8,6 +8,9 @@ COMMANDS
        create
            Create a switch from a compiler source
 
+       reinstall
+           Reinstall the compiler
+
 OPTIONS
        --help[=FMT] (default=auto)
            Show this help in format FMT. The value FMT must be one of `auto',

doc/reinstall.txt

@@ -0,0 +1,38 @@
+NAME
+       opam-compiler-reinstall - Reinstall the compiler
+
+SYNOPSIS
+       opam-compiler reinstall [OPTION]... 
+
+       Reinstall the compiler will propagate the changes done to its source.
+
+       There are two ways to reinstall:
+
+       Full (default)
+           Reinstall the compiler and all the packages in the switch. This
+           can be slow but is always safe.
+
+       Quick (unsafe)
+           Only reinstall the compiler. This is fast, but will break the
+           switch if the way it compiles is modified for example.
+OPTIONS
+       --dry-run
+           Do not perform external commands. Print them and continue as if
+           they worked.
+
+       --full
+           Perform a full reinstallation (default).
+
+       --help[=FMT] (default=auto)
+           Show this help in format FMT. The value FMT must be one of `auto',
+           `pager', `groff' or `plain'. With `auto', the format is `pager` or
+           `plain' whenever the TERM env var is `dumb' or undefined.
+
+       --quick
+           Perform a quick reinstallation (unsafe)
+
+       --switch=SWITCH_NAME
+           Use this name for the switch. If omitted, a name is inferred from
+           the source. This name is used as is by opam, so passing "." will
+           create a local switch in the current directory.
+

lib/cli.ml

@@ -8,10 +8,17 @@ type t =
       runner : Runner.t;
       github_client : Github_client.t;
     }
+  | Reinstall of {
+      mode : Op.reinstall_mode;
+      switch_name : Switch_name.t option;
+      runner : Runner.t;
+    }
 
 let eval = function
   | Create { source; switch_name; configure_command; runner; github_client } ->
       Op.create runner github_client source switch_name ~configure_command
+  | Reinstall { mode; switch_name; runner } ->
+      Op.reinstall runner mode ~name:switch_name
 
 let configure_command_explicit =
   let open Cmdliner.Arg in
@@ -66,14 +73,46 @@ let configure_command =
   in
   Cmdliner.Term.ret ret_term
 
+let dry_run =
+  let open Cmdliner.Arg in
+  let info =
+    info
+      ~doc:
+        "Do not perform external commands. Print them and continue as if they \
+         worked."
+      [ "dry-run" ]
+  in
+  value (flag info)
+
+let clients =
+  let open Let_syntax.Cmdliner in
+  let+ dry_run = dry_run in
+  let runner = if dry_run then Runner.dry_run else Runner.real in
+  let github_client =
+    if dry_run then Github_client.dry_run else Github_client.real
+  in
+  (runner, github_client)
+
+let switch_name =
+  let open Cmdliner.Arg in
+  let conv = conv (Switch_name.parse, Switch_name.pp) in
+  value
+    (opt (some conv) None
+       (info ~docv:"SWITCH_NAME"
+          ~doc:
+            "Use this name for the switch. If omitted, a name is inferred from \
+             the source. This name is used as is by opam, so passing \".\" \
+             will create a local switch in the current directory."
+          [ "switch" ]))
+
 module Create = struct
   module Source_with_original = struct
     type t = { source : Source.t; original : string }
 
-    let of_string s =
-      match Source.parse s with
-      | Ok source -> Ok { source; original = s }
-      | Error `Unknown -> Rresult.R.error_msgf "Invalid source: %S" s
+    let of_string original =
+      let open Let_syntax.Result in
+      let+ source = Source.parse original in
+      { source; original }
 
     let pp ppf { original; _ } = Format.pp_print_string ppf original
 
@@ -88,38 +127,6 @@ module Create = struct
          None
          (info ~doc:"Where to fetch the compiler." ~docv:"SOURCE" []))
 
-  let switch_name =
-    let open Cmdliner.Arg in
-    let conv = conv (Switch_name.parse, Switch_name.pp) in
-    value
-      (opt (some conv) None
-         (info ~docv:"SWITCH_NAME"
-            ~doc:
-              "Use this name for the switch. If omitted, a name is inferred \
-               from the source. This name is used as is by opam, so passing \
-               \".\" will create a local switch in the current directory."
-            [ "switch" ]))
-
-  let dry_run =
-    let open Cmdliner.Arg in
-    let info =
-      info
-        ~doc:
-          "Do not perform external commands. Print them and continue as if \
-           they worked."
-        [ "dry-run" ]
-    in
-    value (flag info)
-
-  let clients =
-    let open Let_syntax.Cmdliner in
-    let+ dry_run = dry_run in
-    let runner = if dry_run then Runner.dry_run else Runner.real in
-    let github_client =
-      if dry_run then Github_client.dry_run else Github_client.real
-    in
-    (runner, github_client)
-
   let man =
     [
       `S Cmdliner.Manpage.s_description;
@@ -132,6 +139,7 @@ module Create = struct
       `I
         ( "Github pull request (short form)",
           "#number (repo defaults to \"ocaml/ocaml\")" );
+      `I ("Directory", "path/to/sources");
     ]
 
   let term =
@@ -149,12 +157,54 @@ module Create = struct
   let command = (term, info)
 end
 
+module Reinstall = struct
+  let reinstall_mode =
+    let open Cmdliner.Arg in
+    value
+      (vflag Op.Full
+         [
+           ( Full,
+             info ~doc:"Perform a full reinstallation (default)." [ "full" ] );
+           ( Quick,
+             info ~doc:"Perform a quick reinstallation (unsafe)" [ "quick" ] );
+         ])
+
+  let term =
+    let open Let_syntax.Cmdliner in
+    let+ mode = reinstall_mode
+    and+ switch_name = switch_name
+    and+ runner, _github_client = clients in
+    Reinstall { mode; switch_name; runner }
+
+  let man =
+    [
+      `P "Reinstall the compiler will propagate the changes done to its source.";
+      `P "There are two ways to reinstall:";
+      `I
+        ( "Full (default)",
+          "Reinstall the compiler and all the packages in the switch. This can \
+           be slow but is always safe." );
+      `I
+        ( "Quick (unsafe)",
+          "Only reinstall the compiler. This is fast, but will break the \
+           switch if the way it compiles is modified for example." );
+    ]
+
+  let info =
+    let open Cmdliner.Term in
+    info ~man ~doc:"Reinstall the compiler" "reinstall"
+
+  let command = (term, info)
+end
+
 let default =
   let open Cmdliner.Term in
   (ret (pure (`Help (`Auto, None))), info "opam-compiler")
 
 let main () =
-  let result = Cmdliner.Term.eval_choice default [ Create.command ] in
+  let result =
+    Cmdliner.Term.eval_choice default [ Create.command; Reinstall.command ]
+  in
   (match result with
   | `Ok op -> eval op |> Rresult.R.failwith_error_msg
   | `Version -> ()

lib/import.ml

@@ -42,10 +42,12 @@ let pp_cmd ppf cmd =
   Bos.Cmd.to_list cmd |> List.map quote_if_needed |> String.concat " "
   |> Format.pp_print_string ppf
 
-type error = [ `Command_failed of Bos.Cmd.t | `Unknown ]
+type error = [ `Command_failed of Bos.Cmd.t | `Unknown | `No_compiler_sources ]
 
 let translate_error s =
   let open Rresult.R in
   reword_error (function
     | `Unknown -> msgf "%s" s
-    | `Command_failed cmd -> msgf "%s - command failed: %a" s pp_cmd cmd)
+    | `Command_failed cmd -> msgf "%s - command failed: %a" s pp_cmd cmd
+    | `No_compiler_sources ->
+        msgf "%s - switch is not linked to compiler sources" s)

lib/import.mli

@@ -27,7 +27,7 @@ val pp_env : Format.formatter -> (string * string) list option -> unit
 
 val pp_cmd : Format.formatter -> Bos.Cmd.t -> unit
 
-type error = [ `Command_failed of Bos.Cmd.t | `Unknown ]
+type error = [ `Command_failed of Bos.Cmd.t | `Unknown | `No_compiler_sources ]
 
 val translate_error :
   string -> ('a, [< error ]) result -> ('a, [> Rresult.R.msg ]) result

lib/op.ml

@@ -9,6 +9,36 @@ let try_ r ~if_command_failed =
       e
   | Error _ as e -> e
 
+let compiler_sources = "sources"
+
+let configure_command = "configure-command"
+
+let decode_using f x =
+  let open Let_syntax.Result in
+  let* ro = x in
+  match ro with
+  | None -> Ok None
+  | Some r -> (
+      match f r with Error _ -> Error `Unknown | Ok p -> Ok (Some p))
+
+let get_compiler_sources runner name =
+  Opam.get_variable runner name ~variable:compiler_sources
+  |> decode_using Fpath.of_string
+
+let set_compiler_sources runner name path =
+  Opam.set_variable runner name ~variable:compiler_sources
+    ~value:(Fpath.to_string path)
+
+let get_configure_command runner name =
+  Opam.get_variable runner name ~variable:configure_command
+  |> decode_using Bos.Cmd.of_string
+
+let set_configure_command runner name command =
+  Opam.set_variable runner name ~variable:configure_command
+    ~value:(Format.asprintf "%a" pp_cmd command)
+
+let iter ~f = function None -> Ok () | Some x -> f x
+
 let create runner github_client source switch_name ~configure_command =
   let switch_name =
     match switch_name with
@@ -23,7 +53,12 @@ let create runner github_client source switch_name ~configure_command =
      try_ (Opam.pin_add runner switch_name url ~configure_command)
        ~if_command_failed:(fun () -> Opam.remove_switch runner switch_name)
    in
-   Opam.set_base runner switch_name)
+   let* () = Opam.set_base runner switch_name in
+   match Source.compiler_sources source with
+   | None -> Ok ()
+   | Some sources ->
+       let* () = set_compiler_sources runner switch_name sources in
+       iter configure_command ~f:(set_configure_command runner switch_name))
   |> translate_error "Cannot create switch"
 
 type reinstall_mode = Quick | Full
@@ -32,8 +67,17 @@ let reinstall_packages_if_needed runner = function
   | Quick -> Ok ()
   | Full -> Opam.reinstall_packages runner
 
-let reinstall runner mode ~configure_command =
+let unwrap_compiler_sources = function
+  | None -> Error `No_compiler_sources
+  | Some v -> Ok v
+
+let reinstall runner mode ~name =
   let open Let_syntax.Result in
-  (let* () = Opam.reinstall_compiler runner ~configure_command in
+  (let* compiler_sources_opt = get_compiler_sources runner name in
+   let* compiler_sources = unwrap_compiler_sources compiler_sources_opt in
+   let* configure_command = get_configure_command runner name in
+   let* () =
+     Opam.reinstall_compiler runner ~compiler_sources ~configure_command
+   in
    reinstall_packages_if_needed runner mode)
   |> translate_error "Could not reinstall"

lib/op.mli

@@ -11,5 +11,5 @@ type reinstall_mode = Quick | Full
 val reinstall :
   Runner.t ->
   reinstall_mode ->
-  configure_command:Bos.Cmd.t option ->
+  name:Switch_name.t option ->
   (unit, [> Rresult.R.msg ]) result