Merge pull request #370 from CraigFe/require-map-in-io

Require an explicit definition of IO.map

bench/cost.ml

@@ -3,6 +3,8 @@ external tick : unit -> (int64[@unboxed]) = "none" "get_tick" [@@noalloc]
 module None = struct
   type +'a t = 'a
 
+  let map f x = f x
+
   let bind x f = f x
 
   let return x = x

src/async/conduit_async.ml

@@ -1,6 +1,8 @@
 module IO = struct
   type +'a t = 'a Async.Deferred.t
 
+  let map f x = Async.Deferred.map ~f x
+
   let bind x f = Async.Deferred.bind x ~f
 
   let return x = Async.Deferred.return x

src/core/conduit.ml

@@ -92,7 +92,7 @@ module Make (IO : IO) (Input : BUFFER) (Output : BUFFER) :
 
   let ( >>= ) x f = IO.bind x f
 
-  let ( >>| ) x f = x >>= fun x -> return (f x)
+  let ( >>| ) x f = IO.map f x
 
   let ( >>? ) x f =
     x >>= function Ok x -> f x | Error err -> return (Error err)

src/core/conduit_intf.ml

@@ -101,6 +101,8 @@ end
 module type IO = sig
   type +'a t
 
+  val map : ('a -> 'b) -> 'a t -> 'b t
+
   val bind : 'a t -> ('a -> 'b t) -> 'b t
 
   val return : 'a -> 'a t

src/lwt/conduit_lwt.ml

@@ -1,6 +1,8 @@
 module IO = struct
   type +'a t = 'a Lwt.t
 
+  let map f x = Lwt.map f x
+
   let bind x f = Lwt.bind x f
 
   let return x = Lwt.return x

src/mirage/conduit_mirage.ml

@@ -1,6 +1,8 @@
 module IO = struct
   type +'a t = 'a Lwt.t
 
+  let map f x = Lwt.map f x
+
   let bind x f = Lwt.bind x f
 
   let return x = Lwt.return x

tests/flow.ml

@@ -1,6 +1,8 @@
 module Unix_scheduler = struct
   type +'a t = 'a
 
+  let map f x = f x
+
   let bind x f = f x
 
   let return x = x

tests/ping-pong/with_async.ml

@@ -5,11 +5,7 @@ let () = Mirage_crypto_rng_unix.initialize ()
 
 include Common.Make
           (struct
-            type +'a t = 'a Async.Deferred.t
-
-            let bind x f = Async.Deferred.bind x ~f
-
-            let return = Async.Deferred.return
+            include Conduit_async.IO
 
             let yield () = Async.Deferred.return ()
           end)

tests/ping-pong/with_lwt.ml

@@ -6,6 +6,7 @@ let failwith fmt = Fmt.kstrf (fun err -> Lwt.fail (Failure err)) fmt
 
 module Lwt = struct
   include Lwt
+  include Conduit_lwt.IO
 
   let yield = Lwt_unix.yield
 end

tests/resolvers.ml

@@ -1,6 +1,8 @@
 module Unix_scheduler = struct
   type +'a t = 'a
 
+  let map f x = f x
+
   let bind x f = f x
 
   let return x = x