First draft - needs some cleanups but seems to work

CHANGES.md

@@ -1,23 +1,27 @@
 ### Unreleased
 
 - This release introduces a significant change in the Mirage tool by
-  splitting the configure-time and runtime keys. Configure-time keys
-  are essential during the setup of module dependencies for the
-  unikernel, allowing for a specialized production of a unikernel for
-  a given target runtime environment. On the other hand, runtime keys
-  are useful for customizing deployments without altering the
-  dependencies of the unikernels. (#1449, #1450, #1451, #1455 @samoht,
-  review by @hannesm)
+  splitting the definition of command-line arguments used at
+  configure-time and runtime. Command-line arguments used in the
+  configure script (also called 'configuration keys' and defined in
+  the `Key` module) are essential during the setup of module
+  dependencies for the unikernel, allowing for a specialized
+  production of a unikernel for a given target runtime environment. On
+  the other hand, command-line arguments that the unikernel can use at
+  runtime (defined in the `Runtime_arg` module) are useful for
+  customizing deployments without altering the dependencies of the
+  unikernels. (#1449, #1450, #1451, #1455 @samoht, review by @hannesm)
 
   * API changes:
     - There is no more `~stage` parameter for `Key.Arg.info`.
-    - `Key` now define configure-time keys only.
-    - There is a new module `Runtime_arg` to define runtime keys.
+    - `Key` now define command-line arguments for the configuration tool.
+    - There is a new module `Runtime_arg` to define command-line arguments
+      for the unikernel.
     - As there are no more keys type `'Both`, users are now expected to create
       two separated keys in that case (one for configure-time, one for runtime)
       or decide if the key is useful at runtime of configure-time.
 
-  * Intended use of configure-time keys (values of type `'a key`):
+  * Intended use of configuration keys (values of type `'a key`):
     - Used to set up module dependencies of the unikernel, such as the
       target (hvt, xen, etc.) and whether to use DHCP or a fixed IP address.
     - Enable the production of specialized unikernels suitable for
@@ -26,16 +30,26 @@
     - Similar keys will produce reproducible binaries to be uploaded to artifact
       repositories like Docker Hub or https://builds.robur.coop/.
 
-  * Intended use of runtime keys (values of type `a runtime_arg`):
+  * Intended use of command-line runtime arguments (values of type
+    `a runtime_arg`):
     - Allow users to customize deployments by changing device
       configuration, like IP addresses, secrets, block device names,
       etc., post downloading of binaries.
     - These keys don’t alter the dependencies of the unikernels.
     - A runtime keys is just a reference to a normal Cmdliner term.
 
-  * Code migration:
+  * `key_gen.ml` is not generated anymore, so users cannot refer to
+    `Key_gen.<key_name>` directy.
+    - Any runtime argument has to be declared (using `runtime_arg` and
+      registered on the device (using `~runtime_args`). The value of that
+      argument will then be passed  as an extra parameter of the `connect`
+      function of that device.
+    - Configuration keys are not available at runtime anymore. For
+      instance, `Key_gen.target` has been removed.
+
+* Code migration:
     ```ocaml
-    (* in `config.ml` *)
+    (* in config.ml *)
     let key =
       let doc = Key.Arg.info ~doc:"A Key." ~stage:`Run [ "key" ] in
       Key.(create "key" Arg.(opt_all ~stage:`Run string doc))
@@ -50,15 +64,29 @@
       Arg.(value & opt_all string [] doc)
     ```
 
-   * Changes in the auto-generated `key_gen.ml` file:
-     - Users are not expected to refer to `Key_gen.<key_name>`
-       directy. Instead, they should use normal Cmdliner
-       terms. `mirage configure` is still generating a `key_gen.ml`
-       file containing (registered) runtime keys that are needed by
-       device-initialisation code.
-     - Configure-time keys are not registerd anymore. This means that
-       they are not available `key_gen.ml` anymore. As a consequence,
-       `Key_gen.target` has been removed.
+    ```ocaml
+    (* in unikernel.ml *)
+    let start _ =
+      let key = Key_gen.hello () in
+      ...
+    ```
+    becomes:
+    ```ocaml
+    (* in config.ml *)
+    let hello = runtime_arg ~pos:__POS__ "Unikernel.hello"
+    let main = main ~runtime_args:[hello] ...
+    ```
+
+    ```
+    (* in unikernel.ml *)
+    let hello =
+      let open Cmdliner in
+      let doc = Arg.info ~doc:"How to say hello." [ "hello" ] in
+      Arg.(value & opt string "Hello World!" doc)
+
+    let start _ hello =
+      ...
+    ```
 
 - BUGFIX: fix `mirage describe` output (#1446 @samoht), add test (#1458 @samoht)
 - Remove ipaddr from runtime (#1437 @samoht, #1465 @hannesm)

lib/functoria/DSL.ml

@@ -29,7 +29,9 @@ type 'a device = ('a, Impl.abstract) Device.t
 type context = Context.t
 type job = Job.t
 type info = Info.t
+type 'a code = 'a Device.code
 
+let code = Device.code
 let package = Package.v
 let ( @-> ) = Type.( @-> )
 let typ = Type.v
@@ -46,9 +48,11 @@ let impl ?packages ?packages_v ?install ?install_v ?keys ?runtime_args
   @@ Device.v ?packages ?packages_v ?install ?install_v ?keys ?runtime_args
        ?extra_deps ?connect ?dune ?configure ?files module_name module_type
 
-let main ?packages ?packages_v ?extra_deps module_name ty =
-  let connect _ = Device.start in
-  impl ?packages ?packages_v ?extra_deps ~connect module_name ty
+let main ~pos ?packages ?packages_v ?extra_deps ?runtime_args module_name ty =
+  let connect _ = Device.start ~pos in
+  impl ?packages ?packages_v ?runtime_args ?extra_deps ~connect module_name ty
 
-let foreign ?packages ?packages_v ?deps module_name ty =
-  main ?packages ?packages_v ?extra_deps:deps module_name ty
+let runtime_arg ~pos ?name ?packages fmt =
+  Fmt.kstr
+    (fun code -> Runtime_arg.v (Runtime_arg.create ~pos ?name ?packages code))
+    fmt

lib/functoria/DSL.mli

@@ -64,10 +64,17 @@ val dep : 'a impl -> abstract_impl
 (** {1:keys Keys} *)
 
 type 'a key = 'a Key.key
-(** The type for command-line parameters. *)
+(** The type for configure-time command-line arguments. *)
 
 type 'a runtime_arg = 'a Runtime_arg.arg
-(** The type for command-line parameters. *)
+(** The type for runtime command-line arguments. *)
+
+val runtime_arg :
+  pos:string * int * int * int ->
+  ?name:string ->
+  ?packages:Package.t list ->
+  ('a, Format.formatter, unit, Runtime_arg.t) format4 ->
+  'a
 
 type abstract_key = Key.t
 (** The type for abstract keys. *)
@@ -127,23 +134,16 @@ val package :
 type info = Info.t
 (** The type for build information. *)
 
-val foreign :
-  ?packages:package list ->
-  ?packages_v:package list value ->
-  ?deps:abstract_impl list ->
-  string ->
-  'a typ ->
-  'a impl
-(** Alias for {!main}, where [?extra_deps] has been renamed to [?deps]. *)
-
 val main :
+  pos:string * int * int * int ->
   ?packages:package list ->
   ?packages_v:package list value ->
   ?extra_deps:abstract_impl list ->
+  ?runtime_args:Runtime_arg.t list ->
   string ->
   'a typ ->
   'a impl
-(** [foreign name typ] is the functor [name], having the module type [typ]. The
+(** [main name typ] is the functor [name], having the module type [typ]. The
     connect code will call [<name>.start].
 
     - If [packages] or [packages_v] is set, then the given packages are
@@ -155,10 +155,16 @@ val main :
 (** {1 Devices} *)
 
 type 'a device = ('a, abstract_impl) Device.t
+type 'a code
 
 val of_device : 'a device -> 'a impl
 (** [of_device t] is the implementation device [t]. *)
 
+val code :
+  pos:string * int * int * int ->
+  ('a, Format.formatter, unit, 'b code) format4 ->
+  'a
+
 val impl :
   ?packages:package list ->
   ?packages_v:package list Key.value ->
@@ -167,7 +173,7 @@ val impl :
   ?keys:Key.t list ->
   ?runtime_args:Runtime_arg.t list ->
   ?extra_deps:abstract_impl list ->
-  ?connect:(info -> string -> string list -> string) ->
+  ?connect:(info -> string -> string list -> 'a code) ->
   ?dune:(info -> Dune.stanza list) ->
   ?configure:(info -> unit Action.t) ->
   ?files:(info -> Fpath.t list) ->

lib/functoria/argv.ml

@@ -21,5 +21,5 @@ type t = ARGV
 let argv = Type.v ARGV
 
 let sys_argv =
-  let connect _ _ _ = "return Sys.argv" in
+  let connect _ _ _ = Device.code ~pos:__POS__ "return Sys.argv" in
   Impl.v ~connect "Sys" argv

lib/functoria/device.ml

@@ -22,7 +22,9 @@ open Astring
 type package = Package.t
 type info = Info.t
 type 'a value = 'a Key.value
-type 'a code = string
+type 'a code = { pos : string * int * int * int; code : string }
+
+let code ~pos fmt = Fmt.kstr (fun code -> { pos; code }) fmt
 
 type ('a, 'impl) t = {
   id : 'a Typeid.t;
@@ -60,7 +62,7 @@ let witness x y = Typeid.witness x.id y.id
 let hash x = Typeid.id x.id
 
 let default_connect _ _ l =
-  Printf.sprintf "return (%s)" (String.concat ~sep:", " l)
+  code ~pos:__POS__ "return (%s)" (String.concat ~sep:", " l)
 
 let niet _ = Action.ok ()
 let nil _ = []
@@ -118,19 +120,21 @@ let keys t = t.keys
 let runtime_args t = t.runtime_args
 let extra_deps t = t.extra_deps
 
-let start impl_name args =
-  Fmt.str "@[%s.start@ %a@]" impl_name Fmt.(list ~sep:sp string) args
+let start ~pos impl_name args =
+  code ~pos "@[%s.start@ %a@]" impl_name Fmt.(list ~sep:sp string) args
 
 let uniq t = Fpath.Set.(elements (of_list t))
 let exec_hook i = function None -> Action.ok () | Some h -> h i
 
-let extend ?packages ?packages_v ?dune ?pre_configure ?post_configure ?files t =
+let extend ?packages ?packages_v ?dune ?pre_configure ?post_configure ?files
+    ?(extra_deps = []) t =
   let files =
     match (files, t.files) with
     | None, None -> None
     | Some f, None | None, Some f -> Some f
     | Some x, Some y -> Some (fun i -> uniq (x i @ y i))
   in
+  let extra_deps = extra_deps @ t.extra_deps in
   let packages =
     Key.(pure List.append $ merge_packages packages packages_v $ t.packages)
   in
@@ -144,7 +148,7 @@ let extend ?packages ?packages_v ?dune ?pre_configure ?post_configure ?files t =
     Option.map (fun dune i -> t.dune i @ dune i) dune
     |> Option.value ~default:t.dune
   in
-  { t with packages; files; configure; dune }
+  { t with packages; files; configure; dune; extra_deps }
 
 let nice_name d =
   module_name d

lib/functoria/device.mli

@@ -63,25 +63,32 @@ val files : ('a, 'b) t -> Info.t -> Fpath.Set.t
 (** [files t info s] is the list of files generated configure-time. *)
 
 val keys : ('a, 'b) t -> Key.t list
-(** [keys t] is the list of keys which can be used to configure [t]. *)
+(** [keys t] is the list of command-line arguments which can be used to
+    configure [t]. *)
 
 val runtime_args : ('a, 'b) t -> Runtime_arg.t list
 (** [runtime_args t] is the list of command-line arguments which can be used to
-    configure [t] at runtime. *)
+    run [t]. *)
 
 (** {1 Code Generation} *)
 
-type 'a code = string
+type 'a code = private { pos : string * int * int * int; code : string }
 (** The type for fragments of code of type ['a]. *)
 
+val code :
+  pos:string * int * int * int ->
+  ('a, Format.formatter, unit, 'b code) format4 ->
+  'a
+(** Generate localised code. *)
+
 val connect : ('a, 'b) t -> Info.t -> string -> string list -> 'a code
 (** [connect t info impl_name args] is the code to execute in order to create a
     new state (usually calling [<module_name t>.connect]) with the arguments
     [args], in the context of the project information [info]. The freshly
     created state will be made available in [var_name t] *)
 
-val start : string -> string list -> 'a code
-(** [start impl_name args] is the code [<impl_name>.start <args>]. *)
+val start : pos:string * int * int * int -> string -> string list -> 'a code
+(** [start ~pos impl_name args] is the code [<impl_name>.start <args>]. *)
 
 val nice_name : _ t -> string
 (** [nice_name d] provides a identifier unique to [d] which is a valid OCaml
@@ -126,6 +133,7 @@ val extend :
   ?pre_configure:(Info.t -> unit Action.t) ->
   ?post_configure:(Info.t -> unit Action.t) ->
   ?files:(Info.t -> Fpath.t list) ->
+  ?extra_deps:'b list ->
   ('a, 'b) t ->
   ('a, 'b) t
 

lib/functoria/engine.ml

@@ -161,24 +161,35 @@ let configure info t =
   iter_actions f t
 
 let meta_init fmt (connect_name, result_name) =
-  Fmt.pf fmt "let _%s =@[@ Lazy.force %s @]in@ " result_name connect_name
+  Fmt.pf fmt "  let _%s = Lazy.force %s in@ " result_name connect_name
 
-let emit_connect fmt (iname, names, connect_string) =
+let pp_pos ppf (file, line, _, _) = Fmt.pf ppf "# %d %S@." line file
+
+let emit_connect fmt (iname, names, runtime_args, connect_code) =
   (* We avoid potential collision between double application
      by prefixing with "_". This also avoid warnings. *)
-  let rnames = List.map (fun x -> "_" ^ x) names in
-  let bind ppf name = Fmt.pf ppf "_%s >>= fun %s ->@ " name name in
-  Fmt.pf fmt "@[<v 2>let %s = lazy (@ %a%a%s@ )@]@." iname
+  let result_names = List.map (fun x -> "_" ^ x) names in
+  let key_names =
+    List.map (fun k -> "_" ^ Runtime_arg.var_name k) runtime_args
+  in
+  let bind_device ppf name = Fmt.pf ppf "  _%s >>= fun %s ->\n" name name in
+  let bind_key ppf k =
+    Fmt.pf ppf "  let _%s = %a in\n" (Runtime_arg.var_name k) Runtime_arg.call k
+  in
+  let { Device.pos; code } = connect_code (result_names @ key_names) in
+  Fmt.pf fmt "let %s = lazy (\n%a%a%a%a  %s@\n);;\n" iname
     Fmt.(list ~sep:nop meta_init)
-    (List.combine names rnames)
-    Fmt.(list ~sep:nop bind)
-    rnames (connect_string rnames)
+    (List.combine names result_names)
+    Fmt.(list ~sep:nop bind_device)
+    result_names
+    Fmt.(list ~sep:nop bind_key)
+    runtime_args pp_pos pos code
 
 let emit_run info init main =
   (* "exit 1" is ok in this code, since cmdliner will print help. *)
-  let force ppf name = Fmt.pf ppf "Lazy.force %s >>= fun _ ->@ " name in
+  let force ppf name = Fmt.pf ppf "Lazy.force %s >>= fun _ ->\n  " name in
   append_main info "emit_run"
-    "@[<v 2>let () =@ let t =@ @[<v 2>%aLazy.force %s@]@ in run t@]"
+    "let () =\n  let t = %aLazy.force %s in\n  run t\n;;"
     Fmt.(list ~sep:nop force)
     init main
 
@@ -188,8 +199,9 @@ let connect ?(init = []) info t =
     let var_name = Device.Graph.var_name v in
     let impl_name = Device.Graph.impl_name v in
     let arg_names = List.map Device.Graph.var_name (args @ deps) in
+    let runtime_args = Device.runtime_args dev in
     append_main info "connect" "%a" emit_connect
-      (var_name, arg_names, Device.connect dev info impl_name)
+      (var_name, arg_names, runtime_args, Device.connect dev info impl_name)
   in
   let* () = iter_actions f t in
   let main_name = Device.Graph.var_name t in

lib/functoria/functoria.ml

@@ -44,21 +44,13 @@ module type KEY =
      and type t = Key.t
      and type Set.t = Key.Set.t
 
-module type RUNTIME_ARG =
-  module type of Runtime_arg
-    with type 'a arg = 'a Runtime_arg.arg
-     and type t = Runtime_arg.t
-     and type Set.t = Runtime_arg.Set.t
-
 (** Devices *)
 
 include DSL
 
 let job = Job.t
 let noop = Job.noop
-
-let keys ?runtime_package ?runtime_modname x =
-  Job.keys ?runtime_package ?runtime_modname x
+let runtime_args = Job.runtime_args
 
 type argv = Argv.t