Merge pull request #1524 from Julow/functoria-constr-main-start

functoria: Constraint the start function to 'unit Lwt.t'

lib/functoria/device.ml

@@ -119,7 +119,9 @@ let runtime_args t = t.runtime_args
 let extra_deps t = t.extra_deps
 
 let start ?pos impl_name args =
-  code_opt ?pos "@[%s.start@ %a@]" impl_name Fmt.(list ~sep:sp string) args
+  code_opt ?pos "@[(%s.start@ %a@ : unit io)@]" 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

lib/functoria/lib.mli

@@ -29,6 +29,7 @@ module type S = sig
 
       It should put in scope:
 
+      - a [io] type as an alias to type ['a t]
       - a [run] function of type ['a t -> 'a]
       - a [return] function of type ['a -> 'a t]
       - a [>>=] operator of type ['a t -> ('a -> 'b t) -> 'b t] *)

lib/mirage.ml

@@ -324,6 +324,7 @@ module Project = struct
   let prelude info =
     Fmt.str
       {ocaml|open Lwt.Infix
+type 'a io = 'a Lwt.t
 let return = Lwt.return
 let run t = %s.Main.run t ; exit 0|ocaml}
       (os_of_target info)

test/functoria/e2e/errors.t

@@ -14,14 +14,14 @@ not the right ones. First, too many parameters:
 
   $ ./test.exe configure -f errors/in_functor_too_many.ml
   $ dune build 2>&1 | head -n1 | cut -d',' -f'-2'
-  File "errors/test/main.ml", line 7
+  File "errors/test/main.ml", line 8
   $ ./test.exe clean -f errors/in_functor_too_many.ml
 
 Then, not enough:
 
   $ ./test.exe configure -f errors/in_functor_not_enough.ml
   $ dune build
-  File "errors/test/main.ml", line 30, characters 2-25:
+  File "errors/test/main.ml", line 31, characters 3-26:
   Error: The module Unikernel_make__4 is a functor, it cannot have any components
   [1]
   $ ./test.exe clean -f errors/in_functor_not_enough.ml

test/functoria/e2e/lib/e2e.ml

@@ -27,7 +27,9 @@ let write_key i k f =
 module C = struct
   open Action.Syntax
 
-  let prelude _ = "let (>>=) x f = f x\nlet return x = x\nlet run x = x"
+  let prelude _ =
+    "let (>>=) x f = f x\ntype 'a io = 'a\nlet return x = x\nlet run x = x"
+
   let name = "test"
   let version = "1.0~test"
   let packages = [ package ~sublibs:[ "functoria" ] "mirage"; package "e2e" ]

test/mirage/random/run.t

@@ -21,6 +21,7 @@ Configure the project for Unix:
   random-unix.opam
   $ cat mirage/main.ml
   open Lwt.Infix
+  type 'a io = 'a Lwt.t
   let return = Lwt.return
   let run t = Unix_os.Main.run t ; exit
   0
@@ -105,29 +106,29 @@ Configure the project for Unix:
   # 7 "lib/devices/argv.ml"
     Bootvar.argv ()
   );;
-  # 86 "mirage/main.ml"
+  # 87 "mirage/main.ml"
 
   let struct_end__2 = lazy (
     let __bootvar__1 = Lazy.force bootvar__1 in
     __bootvar__1 >>= fun _bootvar__1 ->
   # 47 "lib/functoria/job.ml"
     return Mirage_runtime.(with_argv (runtime_args ()) "random" _bootvar__1)
   );;
-  # 94 "mirage/main.ml"
+  # 95 "mirage/main.ml"
 
   let printexc__3 = lazy (
     let _backtrace = backtrace__key () in
-  # 396 "lib/mirage.ml"
+  # 397 "lib/mirage.ml"
     return (Printexc.record_backtrace _backtrace)
   );;
-  # 101 "mirage/main.ml"
+  # 102 "mirage/main.ml"
 
   let hashtbl__4 = lazy (
     let _randomize_hashtables = randomize_hashtables__key () in
-  # 405 "lib/mirage.ml"
+  # 406 "lib/mirage.ml"
     return (if _randomize_hashtables then Hashtbl.randomize ())
   );;
-  # 108 "mirage/main.ml"
+  # 109 "mirage/main.ml"
 
   let gc__5 = lazy (
     let _allocation_policy = allocation_policy__key () in
@@ -140,7 +141,7 @@ Configure the project for Unix:
     let _custom_major_ratio = custom_major_ratio__key () in
     let _custom_minor_ratio = custom_minor_ratio__key () in
     let _custom_minor_max_size = custom_minor_max_size__key () in
-  # 457 "lib/mirage.ml"
+  # 458 "lib/mirage.ml"
     return (
   let open Gc in
     let ctrl = get () in
@@ -156,19 +157,19 @@ Configure the project for Unix:
     custom_minor_max_size = (match _custom_minor_max_size with None -> ctrl.custom_minor_max_size | Some x -> x) })
   )
   );;
-  # 137 "mirage/main.ml"
+  # 138 "mirage/main.ml"
 
   let mirage_runtime__6 = lazy (
     let _delay = delay__key () in
   # 302 "lib/mirage.ml"
     Unix_os.Time.sleep_ns (Duration.of_sec _delay)
   );;
-  # 144 "mirage/main.ml"
+  # 145 "mirage/main.ml"
 
   let pclock__7 = lazy (
     return ()
   );;
-  # 149 "mirage/main.ml"
+  # 150 "mirage/main.ml"
 
   let mirage_logs_make__8 = lazy (
     let __pclock__7 = Lazy.force pclock__7 in
@@ -180,17 +181,17 @@ Configure the project for Unix:
     Logs.set_reporter reporter;
     Lwt.return reporter
   );;
-  # 161 "mirage/main.ml"
+  # 162 "mirage/main.ml"
 
   let unix_os_time__9 = lazy (
     return ()
   );;
-  # 166 "mirage/main.ml"
+  # 167 "mirage/main.ml"
 
   let mclock__10 = lazy (
     return ()
   );;
-  # 171 "mirage/main.ml"
+  # 172 "mirage/main.ml"
 
   let mirage_crypto_rng_mirage_make__11 = lazy (
     let __unix_os_time__9 = Lazy.force unix_os_time__9 in
@@ -200,15 +201,15 @@ Configure the project for Unix:
   # 18 "lib/devices/random.ml"
     Mirage_crypto_rng_mirage_make__11.initialize (module Mirage_crypto_rng.Fortuna)
   );;
-  # 181 "mirage/main.ml"
+  # 182 "mirage/main.ml"
 
   let app_make__12 = lazy (
     let __mirage_crypto_rng_mirage_make__11 = Lazy.force mirage_crypto_rng_mirage_make__11 in
     __mirage_crypto_rng_mirage_make__11 >>= fun _mirage_crypto_rng_mirage_make__11 ->
   # 3 "config.ml"
-    App_make__12.start _mirage_crypto_rng_mirage_make__11
+    (App_make__12.start _mirage_crypto_rng_mirage_make__11 : unit io)
   );;
-  # 189 "mirage/main.ml"
+  # 190 "mirage/main.ml"
 
   let mirage_runtime__13 = lazy (
     let __struct_end__2 = Lazy.force struct_end__2 in
@@ -225,10 +226,10 @@ Configure the project for Unix:
     __mirage_runtime__6 >>= fun _mirage_runtime__6 ->
     __mirage_logs_make__8 >>= fun _mirage_logs_make__8 ->
     __app_make__12 >>= fun _app_make__12 ->
-  # 384 "lib/mirage.ml"
+  # 385 "lib/mirage.ml"
     return ()
   );;
-  # 209 "mirage/main.ml"
+  # 210 "mirage/main.ml"
 
   let () =
     let t = Lazy.force struct_end__2 >>= fun _ ->
@@ -271,6 +272,7 @@ Configure the project for Xen:
   random_libvirt.xml
   $ cat mirage/main.ml
   open Lwt.Infix
+  type 'a io = 'a Lwt.t
   let return = Lwt.return
   let run t = Xen_os.Main.run t ; exit
   0
@@ -355,29 +357,29 @@ Configure the project for Xen:
   # 21 "lib/devices/argv.ml"
     Bootvar.argv ()
   );;
-  # 86 "mirage/main.ml"
+  # 87 "mirage/main.ml"
 
   let struct_end__2 = lazy (
     let __bootvar__1 = Lazy.force bootvar__1 in
     __bootvar__1 >>= fun _bootvar__1 ->
   # 47 "lib/functoria/job.ml"
     return Mirage_runtime.(with_argv (runtime_args ()) "random" _bootvar__1)
   );;
-  # 94 "mirage/main.ml"
+  # 95 "mirage/main.ml"
 
   let printexc__3 = lazy (
     let _backtrace = backtrace__key () in
-  # 396 "lib/mirage.ml"
+  # 397 "lib/mirage.ml"
     return (Printexc.record_backtrace _backtrace)
   );;
-  # 101 "mirage/main.ml"
+  # 102 "mirage/main.ml"
 
   let hashtbl__4 = lazy (
     let _randomize_hashtables = randomize_hashtables__key () in
-  # 405 "lib/mirage.ml"
+  # 406 "lib/mirage.ml"
     return (if _randomize_hashtables then Hashtbl.randomize ())
   );;
-  # 108 "mirage/main.ml"
+  # 109 "mirage/main.ml"
 
   let gc__5 = lazy (
     let _allocation_policy = allocation_policy__key () in
@@ -390,7 +392,7 @@ Configure the project for Xen:
     let _custom_major_ratio = custom_major_ratio__key () in
     let _custom_minor_ratio = custom_minor_ratio__key () in
     let _custom_minor_max_size = custom_minor_max_size__key () in
-  # 457 "lib/mirage.ml"
+  # 458 "lib/mirage.ml"
     return (
   let open Gc in
     let ctrl = get () in
@@ -406,19 +408,19 @@ Configure the project for Xen:
     custom_minor_max_size = (match _custom_minor_max_size with None -> ctrl.custom_minor_max_size | Some x -> x) })
   )
   );;
-  # 137 "mirage/main.ml"
+  # 138 "mirage/main.ml"
 
   let mirage_runtime__6 = lazy (
     let _delay = delay__key () in
   # 302 "lib/mirage.ml"
     Xen_os.Time.sleep_ns (Duration.of_sec _delay)
   );;
-  # 144 "mirage/main.ml"
+  # 145 "mirage/main.ml"
 
   let pclock__7 = lazy (
     return ()
   );;
-  # 149 "mirage/main.ml"
+  # 150 "mirage/main.ml"
 
   let mirage_logs_make__8 = lazy (
     let __pclock__7 = Lazy.force pclock__7 in
@@ -430,17 +432,17 @@ Configure the project for Xen:
     Logs.set_reporter reporter;
     Lwt.return reporter
   );;
-  # 161 "mirage/main.ml"
+  # 162 "mirage/main.ml"
 
   let xen_os_time__9 = lazy (
     return ()
   );;
-  # 166 "mirage/main.ml"
+  # 167 "mirage/main.ml"
 
   let mclock__10 = lazy (
     return ()
   );;
-  # 171 "mirage/main.ml"
+  # 172 "mirage/main.ml"
 
   let mirage_crypto_rng_mirage_make__11 = lazy (
     let __xen_os_time__9 = Lazy.force xen_os_time__9 in
@@ -450,15 +452,15 @@ Configure the project for Xen:
   # 18 "lib/devices/random.ml"
     Mirage_crypto_rng_mirage_make__11.initialize (module Mirage_crypto_rng.Fortuna)
   );;
-  # 181 "mirage/main.ml"
+  # 182 "mirage/main.ml"
 
   let app_make__12 = lazy (
     let __mirage_crypto_rng_mirage_make__11 = Lazy.force mirage_crypto_rng_mirage_make__11 in
     __mirage_crypto_rng_mirage_make__11 >>= fun _mirage_crypto_rng_mirage_make__11 ->
   # 3 "config.ml"
-    App_make__12.start _mirage_crypto_rng_mirage_make__11
+    (App_make__12.start _mirage_crypto_rng_mirage_make__11 : unit io)
   );;
-  # 189 "mirage/main.ml"
+  # 190 "mirage/main.ml"
 
   let mirage_runtime__13 = lazy (
     let __struct_end__2 = Lazy.force struct_end__2 in
@@ -475,10 +477,10 @@ Configure the project for Xen:
     __mirage_runtime__6 >>= fun _mirage_runtime__6 ->
     __mirage_logs_make__8 >>= fun _mirage_logs_make__8 ->
     __app_make__12 >>= fun _app_make__12 ->
-  # 384 "lib/mirage.ml"
+  # 385 "lib/mirage.ml"
     return ()
   );;
-  # 209 "mirage/main.ml"
+  # 210 "mirage/main.ml"
 
   let () =
     let t = Lazy.force struct_end__2 >>= fun _ ->