Add monadic bind and map to types module.

zarr-eio/src/storage.ml

@@ -1,18 +1,20 @@
 module Deferred = struct
   type 'a t = 'a
   let return = Fun.id
+  let bind x f = f x
+  let map f x = f x
   let return_unit = ()
   let iter f xs = Eio.Fiber.List.iter f xs
   let fold_left = List.fold_left
   let concat_map f xs = List.concat (Eio.Fiber.List.map f xs)
 
   module Infix = struct
-    let (>>=) x f = f x
+    let (>>=) = bind
     let (>>|) = (>>=)
   end
 
   module Syntax = struct
-    let (let*) x f = f x
+    let (let*) = bind
     let (let+) = (let*)
   end
 end

zarr-lwt/src/storage.ml

@@ -1,6 +1,8 @@
 module Deferred = struct
   type 'a t = 'a Lwt.t
   let return = Lwt.return
+  let bind = Lwt.bind
+  let map = Lwt.map
   let return_unit = Lwt.return_unit
   let iter = Lwt_list.iter_s
   let fold_left = Lwt_list.fold_left_s
@@ -45,10 +47,7 @@ module FilesystemStore = struct
       Lwt_unix.file_exists parent_dir >>= maybe_create ~perm parent_dir
 
     let size t key =
-      let file_length path () =
-        let+ length = Lwt_io.file_length path in
-        Int64.to_int length
-      in
+      let file_length path () = Lwt.map Int64.to_int (Lwt_io.file_length path) in
       let filepath = key_to_fspath t key in
       Lwt.catch (file_length filepath) (Fun.const @@ Deferred.return 0)
 
@@ -215,12 +214,9 @@ module AmazonS3Store = struct
       let bucket = t.bucket and credentials = t.cred and endpoint = t.endpoint in
       let f ~endpoint () = S3.head ~bucket ~credentials ~key ~endpoint () in
       let* res = S3.retry ~retries:t.retries ~endpoint ~f () in
-      let+ c = fold_or_catch ~not_found:empty_content res in
-      c.size
+      Lwt.map (fun (x : S3.content) -> x.size) (fold_or_catch ~not_found:empty_content res)
 
-    let is_member t key =
-      let+ size = size t key in
-      if size = 0 then false else true
+    let is_member t key = Lwt.map (fun s -> if s = 0 then false else true) (size t key)
 
     let get t key =
       let bucket = t.bucket and credentials = t.cred and endpoint = t.endpoint in
@@ -237,8 +233,7 @@ module AmazonS3Store = struct
         let bucket = t.bucket and credentials = t.cred and endpoint = t.endpoint in
         let f ~endpoint () = S3.get ~bucket ~credentials ~endpoint ~range ~key () in
         let* res = S3.retry ~retries:t.retries ~endpoint ~f () in
-        let+ data = fold_or_catch ~not_found:(raise_not_found key) res in
-        [data]
+        Lwt.map (fun x -> [x]) (fold_or_catch ~not_found:(raise_not_found key) res)
       in
       Deferred.concat_map (read_range t key) ranges
 
@@ -267,8 +262,7 @@ module AmazonS3Store = struct
     let erase t key =
       let bucket = t.bucket and credentials = t.cred and endpoint = t.endpoint in
       let f ~endpoint () = S3.delete ~bucket ~credentials ~endpoint ~key () in
-      let* res = S3.retry ~retries:t.retries ~endpoint ~f () in
-      fold_or_catch ~not_found:(Fun.const ()) res
+      S3.retry ~retries:t.retries ~endpoint ~f () >>= fold_or_catch ~not_found:(Fun.const ())
 
     let rec delete_keys t cont () = 
       let del t xs c = Deferred.iter (delete_content t) xs >>= delete_keys t c in
@@ -326,7 +320,7 @@ module AmazonS3Store = struct
     and rename_and_add ~t ~prefix ~new_prefix acc k =
       let l = String.length prefix in
       let k' = new_prefix ^ String.sub k l (String.length k - l) in
-      let+ a = get t k in (k', a) :: acc
+      Lwt.map (fun a -> (k', a) :: acc) (get t k)
   end
 
   let with_open ?(scheme=`Http) ?(inet=`V4) ?(retries=3) ~region ~bucket ~profile f =

zarr-sync/src/storage.ml

@@ -1,18 +1,20 @@
 module Deferred = struct
   type 'a t = 'a
   let return = Fun.id
+  let bind x f = f x
+  let map f x = f x
   let return_unit = ()
   let iter = List.iter
   let fold_left = List.fold_left
   let concat_map = List.concat_map
 
   module Infix = struct
-    let (>>=) x f = f x
+    let (>>=) = bind
     let (>>|) = (>>=)
   end
 
   module Syntax = struct
-    let (let*) x f = f x
+    let (let*) = bind
     let (let+) = (let*)
   end
 end

zarr/src/storage/storage.ml

@@ -37,8 +37,7 @@ module Make (Io : Types.IO) = struct
     let add ~t ((left, right) as acc) k =
       if not (String.ends_with ~suffix:"zarr.json" k) then Deferred.return acc else
       let path = if k = "zarr.json" then "/" else "/" ^ String.(sub k 0 (length k - 10)) in
-      let+ kind = node_kind t k in
-      choose path left right kind
+      Deferred.map (choose path left right) (node_kind t k)
     in
     list t >>= Deferred.fold_left (add ~t) ([], [])
 
@@ -61,15 +60,12 @@ module Make (Io : Types.IO) = struct
       in
       exists t node >>= maybe_create ~attrs t node
 
-    let metadata t node =
-      let+ data = get t (Node.Group.to_metakey node) in
-      Metadata.Group.decode data
+    let metadata t node = Deferred.map Metadata.Group.decode (get t @@ Node.Group.to_metakey node)
 
     let children t node =
       let add ~t (left, right) prefix =
         let path = "/" ^ String.sub prefix 0 (String.length prefix - 1) in
-        let+ kind = node_kind t (prefix ^ "zarr.json") in
-        choose path left right kind
+        Deferred.map (choose path left right) (node_kind t @@ prefix ^ "zarr.json")
       in
       let maybe_enumerate t node = function
         | false -> Deferred.return ([], [])
@@ -96,16 +92,13 @@ module Make (Io : Types.IO) = struct
       ~codecs ~shape ~chunks
       kind fv node t =
       let c = Codecs.Chain.create chunks codecs in
-      let m = Metadata.Array.create
-        ~sep ~codecs:c ~dimension_names ~attributes ~shape kind fv chunks in
+      let m = Metadata.Array.create ~sep ~codecs:c ~dimension_names ~attributes ~shape kind fv chunks in
       let key = Node.Array.to_metakey node in
       let value = Metadata.Array.encode m in 
       let* () = set t key value in
       Option.fold ~none:Deferred.return_unit ~some:(Group.create t) (Node.Array.parent node)
 
-    let metadata t node =
-      let+ data = get t (Node.Array.to_metakey node) in
-      Metadata.Array.decode data
+    let metadata t node = Deferred.map Metadata.Array.decode (get t @@ Node.Array.to_metakey node)
 
     let delete t node = erase_prefix t (Node.Array.to_key node ^ "/")
 
@@ -151,13 +144,7 @@ module Make (Io : Types.IO) = struct
       let bindings = ArrayMap.bindings m in
       Deferred.iter (update_chunk ~t ~meta ~prefix ~chain ~fv ~repr) bindings
 
-    let read :
-      type a. t ->
-      Node.Array.t ->
-      Indexing.index array ->
-      a Ndarray.dtype ->
-      a Ndarray.t Deferred.t
-      = fun t node slice kind ->
+    let read (type a) t node slice (kind : a Ndarray.dtype) =
       let indexed_fill_value ~fv (i, _) = (i, fv) in
       let indexed_ndarray_value ~arr (i, c) = (i, Ndarray.get arr c) in
       let add_indexed_coord ~meta acc (i, y) =

zarr/src/types.ml

@@ -1,6 +1,8 @@
 module type Deferred = sig
   type 'a t
   val return : 'a -> 'a t
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+  val map : ('a -> 'b) -> 'a t -> 'b t
   val return_unit : unit t
   val iter : ('a -> unit t) -> 'a list -> unit t
   val fold_left : ('acc -> 'a -> 'acc t) -> 'acc -> 'a list -> 'acc t