A few monads to ultimately provide a Resource monad. This was created to work with Tsdl (tiny SDL bindings) which uses a result type (matching the Result monad here). I've found the Resource monad to be useful for a chain of dependent initializations (each step must succeed to continue), with the return value being the pair of a final result, an…

monad.ml

(*
  A few monads... the incentive was to have an easy way to work with Tsdl.

  The "Result" monad corresponds to the result type returned by most Tsdl calls.

  "Release" accumulates a chain of "clean-up" functions.

  Together they form "Resource" which handles Ok/Error results and accumulates
  clean-up functions which are returned.

  The Resource monad has three forms of binding, for convenience:

   resource          >>= fun _ ->
   (result, cleanup) >>+ fun _ ->
   result            >>- fun _ ->

  In the >>+ binding, "cleanup" is a function which takes the value from an
  `Ok result -- so if result is from opening a file or initializing a system
  which returns a handle for close, then "cleanup" is this close function. For
  example, Sdl.create_window, and Sdl.destroy_window can be paired in this way:
    
    Sdl.(create_window ~w ~h title attribs, destroy_window) >>+ fun win ->

  The >>- binding is to include results in the chain which don't have resource cleanup.
*)


module type SIG = sig
  type 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
  val return : 'a -> 'a t
end

module Make (M : SIG) = struct
  include M
  let join mm = bind mm (fun x -> x)
  let map f m = bind m (fun x -> return (f x))
  let bind2 a b f = bind a (fun x -> bind b (f x))
  let ( >>= ) = bind
  let ( >>| ) m f = map f m
  let ( >> ) m f = bind m (fun _ -> f ())
  let lift2 f m1 m2 = m1 >>= fun x -> map (f x) m2
  let ignore m = map (fun _ -> ()) m
end

module Result =
  Make (struct
    type 'a t = [ `Ok of 'a | `Error of string ]
    let bind m f = match m with `Ok x -> f x | `Error _ as e -> e
    let return x = `Ok x
  end)

module Release =
  Make (struct
    type 'a t = 'a * (unit -> unit)
    let bind (v,r) f = let v',r' = f v in (v', fun () -> r' (); r ())
    let return x = (x, fun () -> ())
  end)

module Resource = struct
  include Make (struct
    type 'a t = 'a Result.t Release.t
    let bind (m:'a t) (f: 'a -> 'b t) =
      Release.bind m (function `Ok v -> f v; | `Error _ as e -> Release.return e)
    let return x = Release.return (Result.return x)
  end)
  let pair (m,release) = match m with `Ok v -> (m, fun () -> release v)
                                    | `Error _ as e -> Release.return e
  let (>>+) m f = pair m >>= f
  let (>>-) m f = Release.return m >> f
end