Add RFC 7386 JSON Merge Patch

README.md

@@ -135,6 +135,38 @@ rejected with `DepthLimitExceeded`, and a patch may insert at most
 `json-max-patch-nodes` nodes beyond the combined size of the document and the
 patch before `SizeLimitExceeded`. Neither binds on a hand-written patch.
 
+### JSON Merge Patch
+
+`JSON.merge-patch` implements [RFC 7386](https://www.rfc-editor.org/rfc/rfc7386),
+which is what an HTTP API almost always means by `application/merge-patch+json`.
+The patch is a document shaped like the target, and merging it replaces the
+members it mentions:
+
+```clojure
+(def doc (Result.unsafe-from-success (JSON.parse "{\"a\":1,\"b\":{\"c\":2}}")))
+(def patch (Result.unsafe-from-success (JSON.parse "{\"b\":{\"c\":3},\"d\":4}")))
+
+(JSON.merge-patch @&doc &patch)  ; => {"a":1,"b":{"c":3},"d":4}
+```
+
+A patch that is not an object replaces the target outright, a `null` member
+deletes that key, and a target that is not an object is treated as an empty
+one. Arrays are replaced whole, never merged element by element.
+
+`JSON.merge-diff` builds the smallest patch taking one document to another,
+emitting `null` for dropped members and omitting unchanged ones:
+
+```clojure
+(JSON.merge-diff &doc &other)      ; => {"b":{"c":3},"d":4}
+(JSON.merge-patch @&doc &(JSON.merge-diff &doc &other))  ; => other
+```
+
+Two things the format cannot express: setting a member to `null`, since that
+spelling already means delete, and reaching inside an array. So a `merge-diff`
+whose target introduces a `null` member does not survive the round trip, and
+an array edit costs the whole array. Reach for `JSON.Patch` when you need
+either.
+
 ### Type predicates
 
 ```clojure

json.carp

@@ -745,10 +745,16 @@ If the value is not an object, returns it unchanged.")
       (JSON.Obj m) (let [bv (Box.init v)] (JSON.Obj (Map.put m k &bv)))
       other (do (ignore v) other)))
 
+  (private remove-member)
+  (hidden remove-member)
+  ; `Map.remove` decrements the length whether or not the key was there.
+  (defn remove-member [m k]
+    (let [present (Map.contains? &m k)] (if present (Map.remove m k) m)))
+
   (doc delete-key "removes a key from a JSON object.
 If the value is not an object or the key is absent, returns it unchanged.")
   (defn delete-key [j k]
-    (match j (JSON.Obj m) (JSON.Obj (Map.remove m k)) other other))
+    (match j (JSON.Obj m) (JSON.Obj (JSON.remove-member m k)) other other))
 
   (doc push "appends a value to a JSON array.
 If the value is not an array, returns it unchanged.")
@@ -1445,6 +1451,96 @@ atomic: on failure `doc` is untouched and the error names the operation index.
           (Result.Error
             (JSON.PatchError.init -1 (JSON.PatchErrorKind.NotAnArray)))))))
 
+(defmodule JSON
+  (register merge-patch (Fn [JSON (Ref JSON)] JSON))
+  (doc merge-patch "applies an RFC 7386 JSON Merge Patch to `target`. A patch
+that is not an object replaces the target wholesale, and a target that is not
+an object is treated as an empty one. In an object patch a `null` member
+deletes that key, all others merge recursively, and arrays are replaced rather
+than merged, so a patch reaches neither into an array nor a `null` value.
+
+  (JSON.merge-patch doc &patch)")
+  (defn merge-patch [target patch]
+    (match-ref patch
+      (JSON.Obj p)
+        (let-do [m (match target
+                   (JSON.Obj tm) tm
+                   other (do (ignore other) (the (Map String (Box JSON)) {})))
+                 ks (Map.keys p)
+                 vs (Map.vals p)
+                 i 0
+                 n (Array.length &ks)]
+          (while-do (Int.< i n)
+            (let [k (Array.unsafe-nth &ks i)
+                  v (Box.peek (Array.unsafe-nth &vs i))]
+              (if (JSON.null? v)
+                (set! m (JSON.remove-member m k))
+                (let [old (match (Map.get-maybe &m k)
+                        (Maybe.Just bx) (Box.unbox bx)
+                        (Maybe.Nothing) (JSON.Null))
+                      bv (Box.init (JSON.merge-patch old v))]
+                  (set! m (Map.put m k &bv)))))
+            (set! i (Int.inc i)))
+          (JSON.Obj m))
+      _ (do (ignore target) @patch)))
+
+  (private deleted-members)
+  (hidden deleted-members)
+  (defn deleted-members [am bm]
+    (let-do [m (the (Map String (Box JSON)) {})
+             ks (Map.keys am)
+             null (Box.init (JSON.Null))
+             i 0
+             n (Array.length &ks)]
+      (while-do (Int.< i n)
+        (let [k (Array.unsafe-nth &ks i)]
+          (set! m (if (Map.contains? bm k) m (Map.put m k &null))))
+        (set! i (Int.inc i)))
+      m))
+
+  (register merge-diff (Fn [(Ref JSON) (Ref JSON)] JSON))
+
+  (private diff-member)
+  (hidden diff-member)
+  (register diff-member
+    (Fn
+      [(Ref (Map String (Box JSON))) (Ref String) (Ref JSON)]
+      (Maybe (Box JSON))))
+  (defn diff-member [am k bv]
+    (match (Map.get-maybe am k)
+      (Maybe.Nothing) (Maybe.Just (Box.init @bv))
+      (Maybe.Just av)
+        (if (JSON.= (Box.peek &av) bv)
+          (Maybe.Nothing)
+          (Maybe.Just (Box.init (JSON.merge-diff (Box.peek &av) bv))))))
+
+  (private diff-objs)
+  (hidden diff-objs)
+  (defn diff-objs [am bm]
+    (let-do [m (JSON.deleted-members am bm)
+             ks (Map.keys bm)
+             vs (Map.vals bm)
+             i 0
+             n (Array.length &ks)]
+      (while-do (Int.< i n)
+        (let [k (Array.unsafe-nth &ks i)]
+          (let [d (JSON.diff-member am k (Box.peek (Array.unsafe-nth &vs i)))]
+            (set! m
+                  (match d (Maybe.Nothing) m (Maybe.Just bx) (Map.put m k &bx)))))
+        (set! i (Int.inc i)))
+      (JSON.Obj m)))
+
+  (doc merge-diff "builds the smallest RFC 7386 merge patch taking `a` to `b`,
+emitting `null` for the members `b` drops and omitting the ones it leaves
+alone. A merge patch cannot set a member to `null`, so a `b` that introduces
+one does not survive the round trip through `merge-patch`.
+
+  (JSON.merge-patch @&a &(JSON.merge-diff &a &b))")
+  (defn merge-diff [a b]
+    (match-ref a
+      (JSON.Obj am) (match-ref b (JSON.Obj bm) (JSON.diff-objs am bm) _ @b)
+      _ @b)))
+
 (doc to-json "converts a Carp value to its JSON representation.")
 (definterface to-json (Fn [a] JSON))
 

test/json.carp

@@ -117,6 +117,19 @@
     (for [i 0 n] (set! s (fmt "%s%s1" &s (if (Int.= i 0) "" ","))))
     (fmt "{\"a\":[%s]}" &s)))
 
+(defn merge-eq? [target patch expected]
+  (=
+    &(JSON.merge-patch (parse-json target) &(parse-json patch))
+    &(parse-json expected)))
+
+(defn diff-eq? [a b expected]
+  (= &(JSON.merge-diff &(parse-json a) &(parse-json b)) &(parse-json expected)))
+
+(defn diff-roundtrips? [a b]
+  (let [ja (parse-json a)
+        jb (parse-json b)]
+    (= &(JSON.merge-patch @&ja &(JSON.merge-diff &ja &jb)) &jb)))
+
 (defn patch-err-index [src patch]
   @(JSON.PatchError.index
     &(Result.unsafe-from-error
@@ -2012,4 +2025,141 @@ break")) "str string with newline")
                            "[{\"op\":\"move\",\"from\":\"/a\",\"path\":\"/a/c\"}]")
       (Maybe.Just (JSON.PatchErrorKind.MoveIntoOwnChild)) true
       _ false)
-    "move may not, which RFC 6902 4.4 requires"))
+    "move may not, which RFC 6902 4.4 requires")
+
+  ; the RFC 7386 Appendix A table
+  (assert-true test
+    (merge-eq? "{\"a\":\"b\"}" "{\"a\":\"c\"}" "{\"a\":\"c\"}")
+    "a member present in both is replaced")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"b\"}" "{\"b\":\"c\"}" "{\"a\":\"b\",\"b\":\"c\"}")
+    "a member only in the patch is added")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"b\"}" "{\"a\":null}" "{}")
+    "a null member deletes the only key")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"b\",\"b\":\"c\"}" "{\"a\":null}" "{\"b\":\"c\"}")
+    "a null member deletes one of several keys")
+
+  (assert-true test
+    (merge-eq? "{\"a\":[\"b\"]}" "{\"a\":\"c\"}" "{\"a\":\"c\"}")
+    "an array member is replaced by a scalar")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"c\"}" "{\"a\":[\"b\"]}" "{\"a\":[\"b\"]}")
+    "a scalar member is replaced by an array")
+
+  (assert-true test
+    (merge-eq? "{\"a\":{\"b\":\"c\"}}"
+               "{\"a\":{\"b\":\"d\",\"c\":null}}"
+               "{\"a\":{\"b\":\"d\"}}")
+    "an object member merges and drops its null")
+
+  (assert-true test
+    (merge-eq? "{\"a\":[{\"b\":\"c\"}]}" "{\"a\":[1]}" "{\"a\":[1]}")
+    "arrays are replaced, not merged elementwise")
+
+  (assert-true test
+    (merge-eq? "[\"a\",\"b\"]" "[\"c\",\"d\"]" "[\"c\",\"d\"]")
+    "an array patch replaces an array target")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"b\"}" "[\"c\"]" "[\"c\"]")
+    "an array patch replaces an object target")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"foo\"}" "null" "null")
+    "a null patch replaces the whole target")
+
+  (assert-true test
+    (merge-eq? "{\"a\":\"foo\"}" "\"bar\"" "\"bar\"")
+    "a string patch replaces the whole target")
+
+  (assert-true test
+    (merge-eq? "{\"e\":null}" "{\"a\":1}" "{\"e\":null,\"a\":1}")
+    "a null already in the target survives an unrelated patch")
+
+  (assert-true test
+    (merge-eq? "[1,2]" "{\"a\":\"b\",\"c\":null}" "{\"a\":\"b\"}")
+    "an object patch treats an array target as empty")
+
+  (assert-true test
+    (merge-eq? "{}" "{\"a\":{\"bb\":{\"ccc\":null}}}" "{\"a\":{\"bb\":{}}}")
+    "a null under an absent key adds nothing")
+
+  (assert-true test
+    (merge-eq? "5" "{\"a\":1}" "{\"a\":1}")
+    "an object patch treats a scalar target as empty")
+
+  (assert-true test
+    (merge-eq? "{\"a\":1}" "{}" "{\"a\":1}")
+    "an empty patch is a no-op")
+
+  (assert-true test
+    (diff-eq? "{\"a\":1,\"b\":2}" "{\"a\":1,\"b\":3}" "{\"b\":3}")
+    "merge-diff omits unchanged members")
+
+  (assert-true test
+    (diff-eq? "{\"a\":1}" "{}" "{\"a\":null}")
+    "merge-diff emits null for a dropped member")
+
+  (assert-true test
+    (diff-eq? "{\"a\":{\"x\":1,\"y\":2}}"
+              "{\"a\":{\"x\":1,\"y\":9}}"
+              "{\"a\":{\"y\":9}}")
+    "merge-diff recurses into a changed object member")
+
+  (assert-true test
+    (diff-eq? "{\"a\":[1,2]}" "{\"a\":[1,3]}" "{\"a\":[1,3]}")
+    "merge-diff replaces a changed array whole")
+
+  (assert-true test
+    (diff-eq? "{\"a\":{\"b\":1}}" "{\"a\":{\"b\":1}}" "{}")
+    "merge-diff of equal documents is the empty patch")
+
+  (assert-true test
+    (diff-eq? "{\"a\":1}" "[1,2]" "[1,2]")
+    "merge-diff against a non-object is that document")
+
+  (assert-true test
+    (diff-roundtrips?
+      "{\"title\":\"Goodbye!\",\"author\":{\"givenName\":\"John\",\"familyName\":\"Doe\"},\"tags\":[\"example\",\"sample\"],\"content\":\"This will be unchanged\"}"
+      "{\"title\":\"Hello!\",\"author\":{\"givenName\":\"John\"},\"tags\":[\"example\"],\"content\":\"This will be unchanged\",\"phoneNumber\":\"+01-123-456-7890\"}")
+    "the RFC 7386 section 3 example round-trips")
+
+  (assert-true test
+    (diff-roundtrips?
+      "{\"a\":{},\"b\":[],\"c\":{\"d\":[1,{\"e\":2}]}}"
+      "{\"a\":{\"x\":1},\"b\":[1],\"c\":{\"d\":[1,{\"e\":3}]}}")
+    "empty objects and arrays round-trip")
+
+  (assert-true test
+    (diff-roundtrips? "{\"e\":null,\"x\":1}" "{\"e\":null,\"x\":2}")
+    "a null the two documents share round-trips")
+
+  (assert-true test
+    (diff-roundtrips? "{\"e\":null,\"x\":1}" "{\"x\":1}")
+    "dropping a null member round-trips")
+
+  (assert-true test
+    (diff-roundtrips? "{\"a\":{\"b\":{\"c\":1}}}" "{\"a\":{\"b\":{}}}")
+    "emptying a nested object round-trips")
+
+  (assert-true test
+    (diff-roundtrips? "5" "{\"a\":[1,{\"b\":null}]}")
+    "a scalar becoming an object round-trips")
+
+  (assert-true test
+    (diff-roundtrips? "{\"a\":1}" "[1,2]")
+    "an object becoming an array round-trips")
+
+  (assert-false test
+    (diff-roundtrips? "{}" "{\"a\":null}")
+    "a member newly set to null does not round-trip")
+
+  (assert-true test
+    (= &(JSON.delete-key (parse-json "{\"a\":1}") "b") &(parse-json "{\"a\":1}"))
+    "delete-key on an absent key leaves the object equal to itself"))