# HG changeset patch
# User orbitz <orbitz@gmail.com>
# Date 1460144664 -7200
#      Fri Apr 08 21:44:24 2016 +0200
# Node ID 0c6fa68e4c9dde589aba44e8b42870edcac68e65
# Parent  0000000000000000000000000000000000000000
Move lib to src

diff --git a/src/revops/META b/src/revops/META
new file mode 100644
--- /dev/null
+++ b/src/revops/META
@@ -0,0 +1,6 @@
+name="revops"
+version="1.0.0"
+description="Reversible Operations"
+requires="core"
+archive(byte)="revops.cma"
+archive(native)="revops.cmxa"
diff --git a/src/revops/Makefile b/src/revops/Makefile
new file mode 100644
--- /dev/null
+++ b/src/revops/Makefile
@@ -0,0 +1,22 @@
+CAMLP4=
+
+OCAMLDEP_OPTS=
+OCAMLC_OPTS=$(OCAMLDEP_OPTS) -w '@f@p@u@s@40' -package core
+OCAMLOPT_OPTS=$(OCAMLC_OPTS)
+
+LIB_MODULES=revops.ml revops_fn.ml revops_sys.ml revops_univ.ml revops_univ_fn.ml
+NON_LIB_MODULES=revops_intf.ml revops_univ_intf.ml
+
+BYTE_TARGETS=revops.cma
+NATIVE_TARGETS=revops.cmxa
+
+.PHONY: all test install
+
+all: native-code byte-code
+
+test:
+
+install: install_lib
+
+# Dependencies
+include ../Ocamlrules.mk.in
diff --git a/src/revops/revops.ml b/src/revops/revops.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops.ml
@@ -0,0 +1,13 @@
+(* Implementation for reversible operations. *)
+
+open Core.Std
+
+module Monad = struct
+  type 'a t = 'a
+  let ( >>= ) v f = f v
+  let return = Fn.id
+  let protect = protect
+end
+
+(* Functor application, see revops_fn.ml *)
+include Revops_fn.Make(Monad)
diff --git a/src/revops/revops.mli b/src/revops/revops.mli
new file mode 100644
--- /dev/null
+++ b/src/revops/revops.mli
@@ -0,0 +1,4 @@
+(*
+ * Interface for reversible operations.
+ *)
+include Revops_intf.S with type 'a M.t = 'a
diff --git a/src/revops/revops_fn.ml b/src/revops/revops_fn.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_fn.ml
@@ -0,0 +1,71 @@
+(* Implementation for reversible operations. *)
+
+open Core.Std
+
+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))
+      (Fn.compose return fst)
+      (Fn.compose return snd)
+      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
diff --git a/src/revops/revops_fn.mli b/src/revops/revops_fn.mli
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_fn.mli
@@ -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)
diff --git a/src/revops/revops_intf.ml b/src/revops/revops_intf.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_intf.ml
@@ -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 -> unit t) -> '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
diff --git a/src/revops/revops_sys.ml b/src/revops/revops_sys.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_sys.ml
@@ -0,0 +1,8 @@
+(* Implementation of basic revops for system operations. *)
+
+open Core.Std
+
+let temp_file ?(prefix="Temp") ?(suffix = "CleanMe") () =
+  Revops.Oprev.make
+    (fun () -> Filename.temp_file prefix suffix)
+    (fun filename -> Unix.remove filename)
diff --git a/src/revops/revops_sys.mli b/src/revops/revops_sys.mli
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_sys.mli
@@ -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
diff --git a/src/revops/revops_univ.ml b/src/revops/revops_univ.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_univ.ml
@@ -0,0 +1,1 @@
+include Revops_univ_fn.Make(Revops)
diff --git a/src/revops/revops_univ.mli b/src/revops/revops_univ.mli
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_univ.mli
@@ -0,0 +1,2 @@
+(* Reversible operations using Univ_map as its state type. *)
+include Revops_univ_intf.S with type 'a R.Oprev.t = 'a Revops.Oprev.t
diff --git a/src/revops/revops_univ_fn.ml b/src/revops/revops_univ_fn.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_univ_fn.ml
@@ -0,0 +1,30 @@
+open Core.Std
+
+module Make = functor (Revops : Revops_intf.S) -> struct
+  module R = Revops
+
+  module M = Revops.M
+
+  module KeyOprev = struct
+    type 'a t = 'a Univ_map.Key.t * 'a Revops.Oprev.t
+  end
+
+  let noop =
+    Revops.Oprev.make
+      (Fn.const (M.return Univ_map.empty))
+      (Fn.const (M.return ()))
+
+  let extend first (key, oprev) =
+    let introduce map value = M.return (Univ_map.set map key value) in
+    let eliminate_second map = M.return (Univ_map.find_exn map key) in
+    Revops.compose
+      ~introduce
+      ~eliminate_first:M.return
+      ~eliminate_second
+      ~first
+      ~second:oprev
+
+  let ( +> ) = extend
+
+  let key name = Univ_map.Key.create ~name sexp_of_opaque
+end
diff --git a/src/revops/revops_univ_fn.mli b/src/revops/revops_univ_fn.mli
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_univ_fn.mli
@@ -0,0 +1,4 @@
+(* Reversible operations using Univ_map as its state type. *)
+
+module Make : functor (Revops : Revops_intf.S) ->
+    (Revops_univ_intf.S with type 'a R.Oprev.t = 'a Revops.Oprev.t)
diff --git a/src/revops/revops_univ_intf.ml b/src/revops/revops_univ_intf.ml
new file mode 100644
--- /dev/null
+++ b/src/revops/revops_univ_intf.ml
@@ -0,0 +1,25 @@
+open Core.Std
+
+module type S = sig
+  module R : Revops_intf.S
+
+  module KeyOprev : sig
+    type 'a t = 'a Univ_map.Key.t * 'a R.Oprev.t
+  end
+
+  (* A Univ_map revop that does nothing. *)
+  val noop : Univ_map.t R.Oprev.t
+
+  (* Extend a Univ_map revop with a 'a Revop. *)
+  val extend : Univ_map.t R.Oprev.t ->
+               'a KeyOprev.t ->
+	       Univ_map.t R.Oprev.t
+
+  (* Infix operator version of extend. *)
+  val ( +> ) : Univ_map.t R.Oprev.t ->
+	       'a KeyOprev.t ->
+	       Univ_map.t R.Oprev.t
+
+  (* Creates a Univ_map.Key.t with the opaque serializer. *)
+  val key : string -> 'a Univ_map.Key.t
+end