functoria: Better type-error for the start function

With this change, the error message is no longer about the pattern and
looks clearer.

Unfortunately, the location is still within generated code. This also
requires adding the `'a io` type in the prelude.

    File "bin/mirage/mirage/main.ml", lines 300-305, characters 3-12:
    Error: This expression has type (unit, 'a) result Lwt.t
           but an expression was expected of type unit start = unit Lwt.t
           Type (unit, 'a) result is not compatible with type unit

lib/functoria/device.ml

@@ -119,8 +119,7 @@ let runtime_args t = t.runtime_args
 let extra_deps t = t.extra_deps
 
 let start ?pos impl_name args =
-  code_opt ?pos "@[<hov>@[<hv 2>%s.start@ %a@]@ >>= fun (_ : unit) ->@ return ()@]"
-    impl_name
+  code_opt ?pos "@[(%s.start@ %a@ : unit io)@]" impl_name
     Fmt.(list ~sep:sp string)
     args
 

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,14 +201,13 @@ 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 >>= fun (_ : unit) ->
-  return ()
+    (App_make__12.start _mirage_crypto_rng_mirage_make__11 : unit io)
   );;
   # 190 "mirage/main.ml"
 
@@ -226,7 +226,7 @@ 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 ()
   );;
   # 210 "mirage/main.ml"
@@ -272,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
@@ -356,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
@@ -391,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
@@ -407,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
@@ -431,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
@@ -451,14 +452,13 @@ 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 >>= fun (_ : unit) ->
-  return ()
+    (App_make__12.start _mirage_crypto_rng_mirage_make__11 : unit io)
   );;
   # 190 "mirage/main.ml"
 
@@ -477,7 +477,7 @@ 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 ()
   );;
   # 210 "mirage/main.ml"