monad.ml

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