Parametrize with 'a IO.t

Allows to support other than 'a Lwt.t.

Author: andreypopp

dream/runtime/ppx_deriving_router_runtime.ml

@@ -1,7 +1,20 @@
 open struct
+  module IO :
+    Ppx_deriving_router_runtime_lib.IO with type 'a t = 'a Lwt.t = struct
+    type 'a t = 'a Lwt.t
+
+    let return = Lwt.return
+    let fail = Lwt.fail
+    let bind = Lwt.bind
+    let catch = Lwt_result.catch
+  end
+
   module Request :
-    Ppx_deriving_router_runtime_lib.REQUEST with type t = Dream.request =
-  struct
+    Ppx_deriving_router_runtime_lib.REQUEST
+      with type 'a IO.t = 'a IO.t
+       and type t = Dream.request = struct
+    module IO = IO
+
     type t = Dream.request
 
     let queries = Dream.all_queries
@@ -19,8 +32,11 @@ open struct
 
   module Response :
     Ppx_deriving_router_runtime_lib.RESPONSE
-      with type status = Dream.status
+      with type 'a IO.t = 'a IO.t
+       and type status = Dream.status
        and type t = Dream.response = struct
+    module IO = IO
+
     type status = Dream.status
 
     let status_ok : status = `OK

dream/runtime/ppx_deriving_router_runtime.mli

@@ -1,6 +1,7 @@
 include
   Ppx_deriving_router_runtime_lib.S
-    with type Request.t = Dream.request
+    with type 'a IO.t = 'a Lwt.t
+     and type Request.t = Dream.request
      and type Response.t = Dream.response
      and type Response.status = Dream.status
      and type 'a Return.t = 'a

dream/test/dune

@@ -4,4 +4,6 @@
   (pps ppx_deriving_router.dream melange-json-native.ppx)))
 
 (cram
- (deps ./test.exe (package ppx_deriving_router)))
+ (deps
+  ./test.exe
+  (package ppx_deriving_router)))

native/ppx_deriving_router.ml

@@ -75,14 +75,15 @@ let td_to_ty_handler param td =
         [%type:
           [%t td_to_ty (Some param) td] ->
           Ppx_deriving_router_runtime.request ->
-          [%t param] Ppx_deriving_router_runtime.return Lwt.t]
+          [%t param] Ppx_deriving_router_runtime.return
+          Ppx_deriving_router_runtime.IO.t]
   | None ->
       [%type:
         [%t td_to_ty param td] ->
         Ppx_deriving_router_runtime.request ->
         Ppx_deriving_router_runtime.response
         Ppx_deriving_router_runtime.return
-        Lwt.t]
+        Ppx_deriving_router_runtime.IO.t]
 
 let td_to_ty_enc param td =
   let loc = td.ptype_loc in
@@ -125,8 +126,10 @@ let derive_mount td m =
       Stdlib.List.map
         (fun route ->
           let f f req =
-            Lwt.bind (f req) (fun [%p p [%pat? x, _encode]] ->
-                Lwt.return [%e make_with_encode encode])
+            Ppx_deriving_router_runtime.IO.bind (f req)
+              (fun [%p p [%pat? x, _encode]] ->
+                Ppx_deriving_router_runtime.IO.return
+                  [%e make_with_encode encode])
           in
           Ppx_deriving_router_runtime.Handle.prefix_route
             [%e elist ~loc (List.map m.m_prefix ~f:(estring ~loc))]
@@ -262,12 +265,14 @@ let derive_path td (exemplar, ctors) =
           let pbody, ebody = patt_and_expr ~loc "_body" in
           let expr =
             match leaf.l_body with
-            | None -> [%expr Lwt.return [%e make args]]
+            | None ->
+                [%expr
+                  Ppx_deriving_router_runtime.IO.return [%e make args]]
             | Some (name, body) ->
                 let name = { loc; txt = Lident name } in
                 let args = (name, ebody) :: args in
                 [%expr
-                  Lwt.bind
+                  Ppx_deriving_router_runtime.IO.bind
                     (Ppx_deriving_router_runtime.Request.body [%e req])
                     (fun [%p pbody] ->
                       let [%p pbody] =
@@ -286,7 +291,7 @@ let derive_path td (exemplar, ctors) =
                              .Invalid_body
                                msg)
                       in
-                      Lwt.return [%e make args])]
+                      Ppx_deriving_router_runtime.IO.return [%e make args])]
           in
           let expr =
             [%expr
@@ -433,7 +438,7 @@ let derive_router_td td =
                   (Some [%pat? p, encode])]
               req
             ->
-              Lwt.bind (f p req)
+              Ppx_deriving_router_runtime.IO.bind (f p req)
                 (Ppx_deriving_router_runtime.Handle.encode encode))];
     [%stri
       let [%p pvar ~loc (handle_name td)] =

native/runtime/ppx_deriving_router_runtime_lib.ml

@@ -2,7 +2,18 @@ type http_method = [ `DELETE | `GET | `POST | `PUT ]
 
 module Witness = Ppx_deriving_router_witness
 
+module type IO = sig
+  type 'a t
+
+  val return : 'a -> 'a t
+  val fail : exn -> 'a t
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+  val catch : (unit -> 'a t) -> ('a, exn) result t
+end
+
 module type REQUEST = sig
+  module IO : IO
+
   type t
 
   val path : t -> string
@@ -11,14 +22,16 @@ module type REQUEST = sig
   val queries : t -> (string * string) list
   (* request queries component, url decoded *)
 
-  val body : t -> string Lwt.t
+  val body : t -> string IO.t
   (* request body *)
 
   val method_ : t -> http_method
   (* request method *)
 end
 
 module type RESPONSE = sig
+  module IO : IO
+
   type status
 
   val status_ok : status
@@ -29,7 +42,7 @@ module type RESPONSE = sig
   type t
 
   val respond :
-    status:status -> headers:(string * string) list -> string -> t Lwt.t
+    status:status -> headers:(string * string) list -> string -> t IO.t
 end
 
 module type RETURN = sig
@@ -42,13 +55,15 @@ module type RETURN = sig
 end
 
 module type S = sig
+  module IO : IO
+
   type json = Yojson.Basic.t
 
-  module Request : REQUEST
+  module Request : REQUEST with module IO = IO
 
   type request = Request.t
 
-  module Response : RESPONSE
+  module Response : RESPONSE with module IO = IO
 
   type response = Response.t
 
@@ -70,7 +85,7 @@ module type S = sig
       | Encode_raw : response encode
       | Encode_json : ('a -> json) -> 'a encode
 
-    val encode : 'a encode -> 'a return -> response Lwt.t
+    val encode : 'a encode -> 'a return -> response IO.t
 
     type 'v route =
       | Route : ('a, 'v) Routes.path * 'a * ('v -> 'w) -> 'w route
@@ -82,13 +97,13 @@ module type S = sig
 
     type 'a router
 
-    val make : (request -> 'a Lwt.t) Routes.router -> 'a router
+    val make : (request -> 'a IO.t) Routes.router -> 'a router
 
     val handle :
       'a router ->
-      ('a -> request -> response Lwt.t) ->
+      ('a -> request -> response IO.t) ->
       request ->
-      response Lwt.t
+      response IO.t
     (** handle request given a router and a dispatcher *)
 
     val dispatch :
@@ -99,25 +114,28 @@ module type S = sig
       | `Method_not_allowed
       | `Not_found
       | `Ok of 'a ]
-      Lwt.t
+      IO.t
   end
 end
 
 module Make
     (Request : REQUEST)
-    (Response : RESPONSE)
+    (Response : RESPONSE with module IO = Request.IO)
     (Return : RETURN with type status = Response.status) :
   S
     with type Request.t = Request.t
      and type Response.t = Response.t
      and type Response.status = Response.status
      and type 'a Return.t = 'a Return.t
+     and type 'a IO.t = 'a Request.IO.t
+     and type 'a IO.t = 'a Response.IO.t
      and module Witness = Witness = struct
   type json = Yojson.Basic.t
   type request = Request.t
   type response = Response.t
   type 'a return = 'a Return.t
 
+  module IO = Request.IO
   module Request = Request
   module Response = Response
   module Return = Return
@@ -135,7 +153,7 @@ module Make
       | Encode_raw : response encode
       | Encode_json : ('a -> json) -> 'a encode
 
-    let encode : type a. a encode -> a Return.t -> response Lwt.t =
+    let encode : type a. a encode -> a Return.t -> response IO.t =
      fun enc x ->
       let status =
         Option.value ~default:Response.status_ok (Return.status x)
@@ -145,7 +163,7 @@ module Make
       | Encode_raw, x -> (
           match Return.data x with
           | None -> Response.respond ~status ~headers ""
-          | Some x -> Lwt.return x)
+          | Some x -> IO.return x)
       | Encode_json to_json, x -> (
           match Return.data x with
           | None -> Response.respond ~status ~headers ""
@@ -169,28 +187,28 @@ module Make
 
     let to_route (Route (path, a, f)) = Routes.(map f (route path a))
 
-    type 'a router = (Request.t -> 'a Lwt.t) Routes.router
+    type 'a router = (Request.t -> 'a IO.t) Routes.router
 
     let make x = x
 
     let dispatch (router : _ router) req =
       let target = Request.path req in
       match Routes.match' router ~target with
       | Routes.FullMatch v | Routes.MatchWithTrailingSlash v ->
-          Lwt.bind
-            (Lwt_result.catch (fun () -> v req))
+          IO.bind
+            (IO.catch (fun () -> v req))
             (function
-              | Ok v -> Lwt.return (`Ok v)
+              | Ok v -> IO.return (`Ok v)
               | Error (Invalid_query_parameter (x, y)) ->
-                  Lwt.return (`Invalid_query_parameter (x, y))
+                  IO.return (`Invalid_query_parameter (x, y))
               | Error (Invalid_body reason) ->
-                  Lwt.return (`Invalid_body reason)
-              | Error Method_not_allowed -> Lwt.return `Method_not_allowed
-              | Error exn -> Lwt.fail exn)
-      | Routes.NoMatch -> Lwt.return `Not_found
+                  IO.return (`Invalid_body reason)
+              | Error Method_not_allowed -> IO.return `Method_not_allowed
+              | Error exn -> IO.fail exn)
+      | Routes.NoMatch -> IO.return `Not_found
 
     let handle (router : _ router) f req =
-      Lwt.bind (dispatch router req) (function
+      IO.bind (dispatch router req) (function
         | `Ok v -> f v req
         | `Invalid_query_parameter (param, msg) ->
             Response.respond ~status:Response.status_bad_request