From e72ee321718cf28f0016991bff02c0076a5aec61 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <me@rgrinberg.com>
Date: Wed, 18 Mar 2020 22:34:01 +0000
Subject: [PATCH] Clean up monad handling

Make it more like the way we handle applicative

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
---
 src/dune/coq_lib.ml        | 18 +++++-------------
 src/dune/coq_rules.ml      |  2 +-
 src/stdune/monad.ml        | 19 +++++++++++++++++--
 src/stdune/monad.mli       |  4 +++-
 src/stdune/monad_intf.ml   | 14 +++++++++++++-
 src/stdune/or_exn.ml       | 12 ++++++++++--
 src/stdune/or_exn.mli      |  2 ++
 src/stdune/result.ml       |  4 ++++
 src/stdune/result.mli      |  4 ++++
 src/stdune/top_closure.ml  |  2 +-
 src/stdune/top_closure.mli |  2 +-
 11 files changed, 61 insertions(+), 22 deletions(-)

diff --git a/src/dune/coq_lib.ml b/src/dune/coq_lib.ml
index acafa397863..4bf8e55a80e 100644
--- a/src/dune/coq_lib.ml
+++ b/src/dune/coq_lib.ml
@@ -1,6 +1,6 @@
 (* This file is licensed under The MIT License *)
 (* (c) MINES ParisTech 2018-2019               *)
-(* Written by: Emilio Jesús Gallego Arias      *)
+(* Written by: Emilio Jesús Gallego Arias *)
 
 open! Stdune
 
@@ -117,17 +117,7 @@ module DB = struct
 
   let find_many t ~loc = Result.List.map ~f:(fun name -> resolve t (loc, name))
 
-  (* Where should we move this? *)
-  module Result_monad : Monad_intf.S with type 'a t = 'a Or_exn.t =
-  struct
-    type 'a t = 'a Or_exn.t
-
-    let return x = Ok x
-
-    let ( >>= ) = Result.O.( >>= )
-  end
-
-  module Coq_lib_closure = Top_closure.Make (String.Set) (Result_monad)
+  module Coq_lib_closure = Top_closure.Make (String.Set) (Or_exn)
 
   let requires db t : lib list Or_exn.t =
     let theories =
@@ -139,7 +129,9 @@ module DB = struct
     in
     let open Result.O in
     let allow_private_deps = Option.is_none t.package in
-    let* theories = Result.List.map ~f:(resolve ~allow_private_deps db) theories in
+    let* theories =
+      Result.List.map ~f:(resolve ~allow_private_deps db) theories
+    in
     let key t = Coq_lib_name.to_string (snd t.name) in
     let deps t =
       Result.List.map ~f:(resolve ~allow_private_deps db) t.theories
diff --git a/src/dune/coq_rules.ml b/src/dune/coq_rules.ml
index f68e20ef4b3..ea24adc4beb 100644
--- a/src/dune/coq_rules.ml
+++ b/src/dune/coq_rules.ml
@@ -1,7 +1,7 @@
 (* This file is licensed under The MIT License *)
 (* (c) MINES ParisTech 2018-2019               *)
 (* (c) INRIA 2020                              *)
-(* Written by: Emilio Jesús Gallego Arias      *)
+(* Written by: Emilio Jesús Gallego Arias *)
 
 open! Stdune
 module SC = Super_context
diff --git a/src/stdune/monad.ml b/src/stdune/monad.ml
index 3fba673b122..3fdb46702d6 100644
--- a/src/stdune/monad.ml
+++ b/src/stdune/monad.ml
@@ -1,7 +1,22 @@
-module Id = struct
+module Make (M : Monad_intf.S1_base) = struct
+  include M
+
+  module O = struct
+    let ( let+ ) x f = M.( >>= ) x (fun x -> M.return (f x))
+
+    let ( and+ ) x y =
+      let open M in
+      x >>= fun x ->
+      y >>= fun y -> return (x, y)
+
+    let ( let* ) = M.( >>= )
+  end
+end
+
+module Id = Make (struct
   type 'a t = 'a
 
   let return x = x
 
   let ( >>= ) x f = f x
-end
+end)
diff --git a/src/stdune/monad.mli b/src/stdune/monad.mli
index 516c8ae518c..559b4bd8bac 100644
--- a/src/stdune/monad.mli
+++ b/src/stdune/monad.mli
@@ -1,3 +1,5 @@
 (** Monad signatures *)
 
-module Id : Monad_intf.S with type 'a t = 'a
+module Make (M : Monad_intf.S1_base) : Monad_intf.S1 with type 'a t := 'a M.t
+
+module Id : Monad_intf.S1 with type 'a t = 'a
diff --git a/src/stdune/monad_intf.ml b/src/stdune/monad_intf.ml
index c825d0f1c85..596d2049109 100644
--- a/src/stdune/monad_intf.ml
+++ b/src/stdune/monad_intf.ml
@@ -1,7 +1,19 @@
-module type S = sig
+module type S1_base = sig
   type 'a t
 
   val return : 'a -> 'a t
 
   val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
 end
+
+module type S1 = sig
+  include S1_base
+
+  module O : sig
+    val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+
+    val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
+
+    val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
+  end
+end
diff --git a/src/stdune/or_exn.ml b/src/stdune/or_exn.ml
index 4c16fb2cb64..0065972e87a 100644
--- a/src/stdune/or_exn.ml
+++ b/src/stdune/or_exn.ml
@@ -1,7 +1,15 @@
-type 'a t = ('a, exn) Result.t
-
 let equal eq x y = Result.equal eq Exn.equal x y
 
 let hash h = Result.hash h Exn.hash
 
 let to_dyn f = Result.to_dyn f Exn.to_dyn
+
+type 'a t = ('a, exn) Result.t
+
+include Monad.Make (struct
+  type nonrec 'a t = 'a t
+
+  let return = Result.return
+
+  let ( >>= ) = Result.( >>= )
+end)
diff --git a/src/stdune/or_exn.mli b/src/stdune/or_exn.mli
index 99989ed46b2..c0008c3a865 100644
--- a/src/stdune/or_exn.mli
+++ b/src/stdune/or_exn.mli
@@ -7,3 +7,5 @@ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
 val hash : ('a -> int) -> 'a t -> int
 
 val to_dyn : ('a -> Dyn.t) -> 'a t Dyn.Encoder.t
+
+include Monad_intf.S1 with type 'a t := 'a t
diff --git a/src/stdune/result.ml b/src/stdune/result.ml
index 9056ea3c116..4c61bebe850 100644
--- a/src/stdune/result.ml
+++ b/src/stdune/result.ml
@@ -4,6 +4,8 @@ type ('a, 'error) t = ('a, 'error) result =
 
 let ok x = Ok x
 
+let return = ok
+
 let is_ok = function
   | Ok _ -> true
   | Error _ -> false
@@ -26,6 +28,8 @@ let bind t ~f =
   | Ok x -> f x
   | Error _ as t -> t
 
+let ( >>= ) x f = bind x ~f
+
 let map x ~f =
   match x with
   | Ok x -> Ok (f x)
diff --git a/src/stdune/result.mli b/src/stdune/result.mli
index d590a9c6323..41fa8e60d84 100644
--- a/src/stdune/result.mli
+++ b/src/stdune/result.mli
@@ -4,6 +4,8 @@ type ('a, 'error) t = ('a, 'error) result =
   | Ok of 'a
   | Error of 'error
 
+val return : 'a -> ('a, _) t
+
 val ok : 'a -> ('a, _) t
 
 val is_ok : _ t -> bool
@@ -37,6 +39,8 @@ val map : ('a, 'error) t -> f:('a -> 'b) -> ('b, 'error) t
 
 val bind : ('a, 'error) t -> f:('a -> ('b, 'error) t) -> ('b, 'error) t
 
+val ( >>= ) : ('a, 'error) t -> ('a -> ('b, 'error) t) -> ('b, 'error) t
+
 val map_error : ('a, 'error1) t -> f:('error1 -> 'error2) -> ('a, 'error2) t
 
 val to_option : ('a, 'error) t -> 'a option
diff --git a/src/stdune/top_closure.ml b/src/stdune/top_closure.ml
index bd1756038df..49c59303082 100644
--- a/src/stdune/top_closure.ml
+++ b/src/stdune/top_closure.ml
@@ -1,4 +1,4 @@
-module Make (Keys : Top_closure_intf.Keys) (Monad : Monad_intf.S) = struct
+module Make (Keys : Top_closure_intf.Keys) (Monad : Monad_intf.S1) = struct
   open Monad
 
   let top_closure ~key ~deps elements =
diff --git a/src/stdune/top_closure.mli b/src/stdune/top_closure.mli
index 00fb09355c5..b5a7e53c141 100644
--- a/src/stdune/top_closure.mli
+++ b/src/stdune/top_closure.mli
@@ -4,6 +4,6 @@ module Int :
 module String :
   Top_closure_intf.S with type key := string and type 'a monad := 'a Monad.Id.t
 
-module Make (Keys : Top_closure_intf.Keys) (Monad : Monad_intf.S) :
+module Make (Keys : Top_closure_intf.Keys) (Monad : Monad_intf.S1) :
   Top_closure_intf.S with type key := Keys.elt and type 'a monad := 'a Monad.t
 [@@inlined always]