Skip to content

Instantly share code, notes, and snippets.

@atavener
Last active September 22, 2018 14:43
Show Gist options
  • Save atavener/64b0325530298b507c0c to your computer and use it in GitHub Desktop.
Save atavener/64b0325530298b507c0c to your computer and use it in GitHub Desktop.
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…
(*
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment