From 1ddefcb66457bcee47937a64c269a3994c8c16c1 Mon Sep 17 00:00:00 2001
From: sneeker <s@cpl0.zip>
Date: Sun, 17 Feb 2019 03:07:54 +0000
Subject: [PATCH] Implement replacement and functional updates with lens-law
 checks

---
 fieldglass.ml  | 2 ++
 fieldglass.mli | 2 ++
 runtime.ml     | 9 +++++++++
 3 files changed, 13 insertions(+)

diff --git a/fieldglass.ml b/fieldglass.ml
index d42e44d..81ed814 100644
--- a/fieldglass.ml
+++ b/fieldglass.ml
@@ -3,3 +3,5 @@ type ('s, 'a) lens' = ('s, 's, 'a, 'a) lens
 
 let lens ~view ~set = view, set
 let view (get, _) = get
+let set (_, put) = put
+let over (get, put) ~f source = put (f (get source)) source
diff --git a/fieldglass.mli b/fieldglass.mli
index b8055af..75190ad 100644
--- a/fieldglass.mli
+++ b/fieldglass.mli
@@ -3,3 +3,5 @@ type ('s, 'a) lens' = ('s, 's, 'a, 'a) lens
 
 val lens : view:('s -> 'a) -> set:('b -> 's -> 't) -> ('s, 't, 'a, 'b) lens
 val view : ('s, 't, 'a, 'b) lens -> 's -> 'a
+val set : ('s, 't, 'a, 'b) lens -> 'b -> 's -> 't
+val over : ('s, 't, 'a, 'b) lens -> f:('a -> 'b) -> 's -> 't
diff --git a/runtime.ml b/runtime.ml
index 14b0ade..9027da9 100644
--- a/runtime.ml
+++ b/runtime.ml
@@ -4,3 +4,12 @@ let sample : (string * bool, string) lens' =
   lens ~view:fst ~set:(fun value (_, other) -> value, other)
 
 let () = assert (view sample ("colour", true) = "colour")
+
+let () =
+  let source = "colour", true in
+  assert (set sample "grey" source = ("grey", true));
+  assert (set sample (view sample source) source = source);
+  assert (set sample "blue" (set sample "grey" source) = set sample "blue" source);
+  let calls = ref 0 in
+  assert (over sample ~f:(fun text -> incr calls; text ^ "s") source = ("colours", true));
+  assert (!calls = 1)