From 51d751a4d74755005029ddcba4d376200903e4c9 Mon Sep 17 00:00:00 2001 From: "carpentry-heartbeat[bot]" Date: Fri, 7 Aug 2026 09:35:16 +0200 Subject: [PATCH] Add RFC 7386 JSON Merge Patch `JSON.merge-patch` applies a merge patch with the RFC's semantics: a non-object patch replaces the target, a `null` member deletes a key, everything else merges recursively, and a non-object target starts out as an empty object. Arrays are replaced whole, so the format can address neither a position inside an array nor a member whose value should become `null`; both docstrings say so rather than pretending otherwise. `JSON.merge-diff` builds the smallest patch taking one document to another, which is the half of the pair that is awkward to write by hand. Tests cover the full Appendix A table plus a round-trip property over hand-built nested documents, including the case that provably cannot round-trip. Core's `Map.remove` decrements a map's length whether or not the key was present, so deleting an absent key left a map whose `Map.length` disagreed with its contents and compared unequal under `JSON.=`. A merge patch deletes absent keys routinely, and `JSON.delete-key` already had the same bug against its documented behaviour; both now go through a guard. --- README.md | 32 +++++++++++ json.carp | 98 ++++++++++++++++++++++++++++++- test/json.carp | 152 ++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 280 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 4bb5d4f..ea246e1 100644 --- a/README.md +++ b/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 diff --git a/json.carp b/json.carp index 18b9993..3c5a850 100644 --- a/json.carp +++ b/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)) diff --git a/test/json.carp b/test/json.carp index ee93ca6..759c16e 100644 --- a/test/json.carp +++ b/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"))