A => src/revops/revops.ml +11 -0
@@ 0,0 1,11 @@
+(* Implementation for reversible operations. *)
+
+module Monad = struct
+ type 'a t = 'a
+ let ( >>= ) v f = f v
+ let return = CCFun.id
+ let protect ~f ~finally = CCFun.finally ~f ~h:finally
+end
+
+(* Functor application, see revops_fn.ml *)
+include Revops_fn.Make(Monad)
A => src/revops/revops.mli +4 -0
@@ 0,0 1,4 @@
+(*
+ * Interface for reversible operations.
+ *)
+include Revops_intf.S with type 'a M.t = 'a
A => src/revops/revops_fn.ml +69 -0
@@ 0,0 1,69 @@
+(* Implementation for reversible operations. *)
+
+module Make = functor (Monad : Revops_intf.MONAD) -> struct
+ module M = Monad
+
+ module Oprev = struct
+ type 'a t = (unit -> 'a M.t) * ('a -> unit M.t)
+
+ let make do_fun undo_fun = (do_fun, undo_fun)
+ end
+
+ module Revop = struct
+ type 'a t = ('a * ('a -> unit M.t))
+ end
+
+ open M
+
+ let doop (do_fun, undo_fun) =
+ do_fun ()
+ >>= fun undo_state ->
+ return (undo_state, undo_fun)
+
+ let undo (undo_state, undo_fun) = undo_fun undo_state
+
+ let peek (undo_state, undo_fun) = undo_state
+
+ let compose ~introduce
+ ~eliminate_first
+ ~eliminate_second
+ ~first
+ ~second =
+ let (_, undo_first) = first in
+ let (_, undo_second) = second in
+ let do_fun () =
+ doop first
+ >>= fun first_revop ->
+ doop second
+ >>= fun second_revop ->
+ introduce (peek first_revop) (peek second_revop)
+ in
+ let undo_fun undo_state =
+ eliminate_second undo_state
+ >>= fun second_state ->
+ undo_second second_state
+ >>= fun () ->
+ eliminate_first undo_state
+ >>= fun first_state ->
+ undo_first first_state
+ in
+ Oprev.make do_fun undo_fun
+
+ let compose_tuple first second =
+ compose
+ (fun l r -> return (l, r))
+ (CCFun.compose fst return)
+ (CCFun.compose snd return)
+ first
+ second
+
+ let ( +* ) = compose_tuple
+
+ let run_in_context oprev action =
+ doop oprev
+ >>= fun revop ->
+ let unit_action () = action (peek revop) in
+ M.protect
+ ~f:unit_action
+ ~finally:(fun () -> undo revop)
+end
A => src/revops/revops_fn.mli +7 -0
@@ 0,0 1,7 @@
+(*
+ * Interface for reversible operations.
+ *)
+
+module Make :
+ functor (Monad : Revops_intf.MONAD) ->
+ (Revops_intf.S with type 'a M.t = 'a Monad.t)
A => src/revops/revops_intf.ml +52 -0
@@ 0,0 1,52 @@
+module type MONAD = sig
+ type 'a t
+
+ val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t
+ val return : 'a -> 'a t
+ val protect : f:(unit -> 'a t) -> finally:(unit -> 'b) -> 'a t
+end
+
+module type S = sig
+ module M : MONAD
+
+ module Oprev : sig
+ type 'a t
+ val make : (unit -> 'a M.t) -> ('a -> unit M.t) -> 'a t
+ end
+
+ module Revop : sig
+ type 'a t
+ end
+
+ val doop : 'a Oprev.t -> 'a Revop.t M.t
+
+ val undo : 'a Revop.t -> unit M.t
+
+ val peek : 'a Revop.t -> 'a
+
+ (*
+ * Composes two oprevs. The order of evaluation on a doop of the result is the first
+ * oprev is setup and then the second. The order of evaluation on an undo is the
+ * second oprev is torn-down and then the first.
+ *)
+ val compose : introduce:('a -> 'b -> 'c M.t) ->
+ eliminate_first:('c -> 'a M.t) ->
+ eliminate_second:('c -> 'b M.t) ->
+ first:'a Oprev.t ->
+ second:'b Oprev.t ->
+ 'c Oprev.t
+
+ val compose_tuple : 'a Oprev.t -> 'b Oprev.t -> ('a * 'b) Oprev.t
+
+ (* Infix shorthand for compose tuple. *)
+ val ( +* ) : 'a Oprev.t -> 'b Oprev.t -> ('a * 'b) Oprev.t
+
+ (*
+ * Runs a unit function in the context of an oprev.
+ * 1. doop the oprev.
+ * 2. Runs the unit function.
+ * 3. undo the revop.
+ * 4. Returns the value from the unit function.
+ *)
+ val run_in_context : 'a Oprev.t -> ('a -> 'b M.t) -> 'b M.t
+end
A => src/revops/revops_sys.ml +6 -0
@@ 0,0 1,6 @@
+(* Implementation of basic revops for system operations. *)
+
+let temp_file ?(prefix="Temp") ?(suffix = "CleanMe") () =
+ Revops.Oprev.make
+ (fun () -> Filename.temp_file prefix suffix)
+ (fun filename -> Unix.unlink filename)
A => src/revops/revops_sys.mli +6 -0
@@ 0,0 1,6 @@
+(* Interface for basic revops for system operations. *)
+
+(*
+ * A revop for creating a temporary file and cleaning up afterward.
+ *)
+val temp_file : ?prefix:string -> ?suffix:string -> unit -> string Revops.Oprev.t