From d8fcaaf69bc835db9eef14c0bedcda1cfbd95fc3 Mon Sep 17 00:00:00 2001
From: Leandro Ostera <leandro@ostera.io>
Date: Sat, 26 May 2018 21:34:47 +0200
Subject: [PATCH 1/2] Add Monad interface and functors

---
 jscomp/others/belt_Monad.ml | 130 ++++++++++++++++++++++++++++++++++++
 1 file changed, 130 insertions(+)
 create mode 100644 jscomp/others/belt_Monad.ml

diff --git a/jscomp/others/belt_Monad.ml b/jscomp/others/belt_Monad.ml
new file mode 100644
index 0000000000..5ac04b5b50
--- /dev/null
+++ b/jscomp/others/belt_Monad.ml
@@ -0,0 +1,130 @@
+module type Base = sig
+  (*
+    Base module that defines a monad.
+    Separate from S since all other functions can be derived from these ones.
+  *)
+  type 'a t
+
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+  val return : 'a -> 'a t
+end
+
+module type Infix = sig
+  (*
+    Common operators to operate with monadic values
+  *)
+  type 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (>>|) : 'a t -> ('a -> 'b) -> 'b t
+end
+
+module type S = sig
+  include Infix
+
+  module Monad_infix : Infix with type 'a t := 'a t
+
+  val bind : 'a t -> ('a -> 'b t) -> 'b t
+  val return : 'a -> 'a t
+  val map : 'a t -> f:('a -> 'b) -> 'b t
+  val join : 'a t t -> 'a t
+  val ignore : 'a t -> unit t
+end
+
+(**
+  Monad construction functor.
+
+  Used to create monad instances for different types, automatically defining
+  operators and functions over them.
+*)
+module Make (M : Base) : S with type 'a t := 'a M.t = struct
+  let bind = M.bind
+  let return = M.return
+
+  module Monad_infix = struct
+    let (>>=) = bind
+    let (>>|) t f = t >>= fun a -> return (f a)
+  end
+  include Monad_infix
+
+  let join t = t >>= fun t' -> t'
+  let map t ~f = t >>| f
+  let ignore t = map t ~f:(fun _ -> ())
+end
+
+
+(**
+   Two parameter monad below!
+
+   This particular signatures are prepared for the Result type, and as such will
+   preserve the second type, allowing you to only change the first one.
+*)
+
+module type Base2 = sig
+  type ('a, 'd) t
+  val bind : ('a, 'd) t -> ('a -> ('b, 'd) t) -> ('b, 'd) t
+  val return : 'a -> ('a, _) t
+end
+
+module type Infix2 = sig
+  type ('a, 'd) t
+  val (>>=) : ('a, 'd) t -> ('a -> ('b, 'd) t) -> ('b, 'd) t
+  val (>>|) : ('a, 'd) t -> ('a -> 'b) -> ('b, 'd) t
+end
+
+module type S2 = sig
+  include Infix2
+  module Monad_infix : Infix2 with type ('a, 'd) t := ('a, 'd) t
+  val bind : ('a, 'd) t -> ('a -> ('b, 'd) t) -> ('b, 'd) t
+  val return : 'a -> ('a, _) t
+  val map : ('a, 'd) t -> f:('a -> 'b) -> ('b, 'd) t
+  val join : (('a, 'd) t, 'd) t -> ('a, 'd) t
+  val ignore : (_, 'd) t -> (unit, 'd) t
+end
+
+(*
+  This module is used to type check that the single and multiparameter monad
+  instances do not deviate from each other, but rather S2 _refines_ S.
+
+  A similar one would be required if we included S3 or monads parametrised over
+  more than 2 types.
+*)
+module Check_S2_refines_S (X : S) : (S2 with type ('a, 'd) t = 'a X.t) =
+struct
+  type ('a, 'd) t = 'a X.t
+  include struct
+    open X
+    let (>>=)      = (>>=)
+    let (>>|)      = (>>|)
+    let bind       = bind
+    let return     = return
+    let map        = map
+    let join       = join
+    let ignore     = ignore
+  end
+  module Monad_infix = struct
+    open X.Monad_infix
+    let (>>=) = (>>=)
+    let (>>|) = (>>|)
+  end
+end
+
+(**
+  Monad construction functor for monads parametrised over two types.
+
+  Used to create monad instances for different types, automatically defining
+  operators and functions over them.
+*)
+module Make2 (M : Base2) : S2 with type ('a, 'd) t := ('a, 'd) M.t = struct
+  let bind = M.bind
+  let return = M.return
+
+  module Monad_infix = struct
+    let (>>=) = bind
+    let (>>|) t f = t >>= fun a -> return (f a)
+  end
+  include Monad_infix
+
+  let join t = t >>= fun t' -> t'
+  let map t ~f = t >>| f
+  let ignore t = map t ~f:(fun _ -> ())
+end

From 95fd06a21d96c13098e0a35e779d4a072c2e833b Mon Sep 17 00:00:00 2001
From: Leandro Ostera <leandro@ostera.io>
Date: Sat, 26 May 2018 21:35:17 +0200
Subject: [PATCH 2/2] Add Result and Option monad instances

---
 jscomp/others/belt_Option.ml | 9 +++++++++
 jscomp/others/belt_Result.ml | 9 +++++++++
 2 files changed, 18 insertions(+)

diff --git a/jscomp/others/belt_Option.ml b/jscomp/others/belt_Option.ml
index c797780e88..52d4f5735d 100644
--- a/jscomp/others/belt_Option.ml
+++ b/jscomp/others/belt_Option.ml
@@ -72,3 +72,12 @@ let cmpU a b f = match (a, b) with
   | (None, None) -> 0
 
 let cmp a b f = cmpU a b (fun[@bs] x y -> f x y)
+
+include (Belt_Monad.Make (struct
+  type 'a t = 'a option
+  let return x = Some x
+  let bind o f =
+    match o with
+    | None -> None
+    | Some x -> f x
+end) : Belt_Monad.S with type 'a t := 'a option)
diff --git a/jscomp/others/belt_Result.ml b/jscomp/others/belt_Result.ml
index e9223552d5..11906fed22 100644
--- a/jscomp/others/belt_Result.ml
+++ b/jscomp/others/belt_Result.ml
@@ -75,3 +75,12 @@ let cmpU a b f = match (a, b) with
   | (Error _, Error _) -> 0
 
 let cmp a b f = cmpU a b (fun[@bs] x y -> f x y)
+
+include (Belt_Monad.Make2
+(struct
+  type ('a 'b) t = ('a 'b) Belt_Result.t
+  let return x = Ok x
+  let bind r f = match r with
+    | Error _ as x -> x
+    | Ok x -> f x
+end) : Belt_Monad.S2 with type ('a 'b) t := ('a 'b) t)