crdt library in ocaml implementing json-joy

Fix compact codec conformance after simdjsont migration

+3
.beads/issues.jsonl
··· 56 {"id":"automerge-P8","title":"Phase 8: Conformance testing","description":"Implement full conformance test suite using json-crdt-traces fixtures plus fuzzing/property tests.","status":"open","priority":1,"issue_type":"epic","created_at":"2025-12-26T11:45:05.443231113+01:00","updated_at":"2025-12-26T11:45:05.443231113+01:00","labels":["conformance","epic","phase-8","testing"],"dependencies":[{"issue_id":"automerge-P8","depends_on_id":"automerge-P7","type":"parent-child","created_at":"2025-12-26T13:51:16.084904641+01:00","created_by":"gdiazlo"}]} 57 {"id":"crdt-4pq","title":"Fix RGA concurrent insert ordering for json-joy compatibility","description":"The RGA algorithm's tie-breaking for concurrent inserts doesn't match json-joy's implementation. When two replicas insert at the same position concurrently, the resulting order differs.\n\nEvidence from conformance tests:\n- Expected: \"An epic synopsis\" \n- Got: \"A synepic nopsis\" (the \"n\" from \"An\" appears in wrong position)\n\nNeed to analyze json-joy's RGA implementation and match its ordering rules:\n- Understand how json-joy determines concurrent inserts\n- Match tie-breaking logic for timestamp comparison\n- May need to track causal dependencies to determine concurrency","status":"closed","priority":1,"issue_type":"bug","assignee":"claude","created_at":"2025-12-26T17:19:31.628018647+01:00","updated_at":"2025-12-26T17:45:10.110299973+01:00","closed_at":"2025-12-26T17:45:10.110299973+01:00","labels":["conformance","crdt","json-joy","rga"]} 58 {"id":"crdt-4ra","title":"Reduce binary codec output size (currently 4x larger than json-joy)","description":"Binary output is 4.9KB vs json-joy's ~1.2KB for 1K chars.\nInvestigate:\n1. Timestamp encoding efficiency (delta encoding?)\n2. RGA chunk representation\n3. Node type encoding overhead\n4. Compare byte-by-byte with json-joy format","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-27T00:34:56.319523298+01:00","updated_at":"2025-12-27T09:29:04.871828606+01:00","closed_at":"2025-12-27T09:29:04.871828606+01:00","labels":["binary-codec","optimization","performance","size"],"dependencies":[{"issue_id":"crdt-4ra","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:34:56.320955254+01:00","created_by":"gdiazlo"}]} 59 {"id":"crdt-7f0","title":"Optimize RGA sequential insert (O(n²) -\u003e O(n log n))","description":"Sequential insert of 10K chars takes 284ms - this is O(n²) behavior.\nOptions:\n1. Use tree-based structure (AVL, finger tree) instead of list\n2. Add index for fast position lookup\n3. Consider json-joy's B+tree approach\n\nTarget: \u003c 50ms for 10K sequential inserts","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:35:00.551809524+01:00","updated_at":"2025-12-27T00:46:27.873263358+01:00","closed_at":"2025-12-27T00:46:27.873263358+01:00","labels":["optimization","performance","rga"],"dependencies":[{"issue_id":"crdt-7f0","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:35:00.557418209+01:00","created_by":"gdiazlo"}]} 60 {"id":"crdt-9h3","title":"Optimize binary encoding performance (currently 3x slower than json-joy)","description":"Binary encoding is ~21K ops/sec vs json-joy's ~108K ops/sec.\nInvestigate:\n1. Buffer allocation strategy\n2. Varint encoding efficiency\n3. CBOR encoding overhead\n4. Consider pre-allocating buffers based on model size","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:34:52.454913078+01:00","updated_at":"2025-12-27T00:41:24.590935842+01:00","closed_at":"2025-12-27T00:41:24.590935842+01:00","labels":["binary-codec","optimization","performance"],"dependencies":[{"issue_id":"crdt-9h3","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:34:52.456412445+01:00","created_by":"gdiazlo"}]} 61 {"id":"crdt-9ry","title":"Run final benchmarks and compare with json-joy","description":"After all optimizations:\n1. Run full benchmark suite\n2. Verify all tests pass\n3. Document comparison with json-joy\n4. Target: exceed json-joy performance across all metrics","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-27T00:35:14.61471182+01:00","updated_at":"2025-12-27T00:46:58.828283923+01:00","closed_at":"2025-12-27T00:46:58.828283923+01:00","labels":["benchmarks","documentation"],"dependencies":[{"issue_id":"crdt-9ry","depends_on_id":"crdt-apw","type":"blocks","created_at":"2025-12-27T00:35:14.620794117+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-9h3","type":"blocks","created_at":"2025-12-27T00:35:14.621445689+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-4ra","type":"blocks","created_at":"2025-12-27T00:35:14.621869631+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-7f0","type":"blocks","created_at":"2025-12-27T00:35:14.622264163+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-z3n","type":"blocks","created_at":"2025-12-27T00:35:14.622793455+01:00","created_by":"gdiazlo"}]} 62 {"id":"crdt-apw","title":"Investigate binary decode performance (35M ops/sec seems wrong)","description":"Binary decode shows 35M ops/sec which is suspiciously fast. Need to verify:\n1. The decode is actually doing work (not returning cached/memoized result)\n2. The decoded model is correct and usable\n3. Add validation that decoded model matches original","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:34:47.948086278+01:00","updated_at":"2025-12-27T00:38:53.472587773+01:00","closed_at":"2025-12-27T00:38:53.472587773+01:00","labels":["binary-codec","investigation","performance"],"dependencies":[{"issue_id":"crdt-apw","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:34:47.954081564+01:00","created_by":"gdiazlo"}]} 63 {"id":"crdt-icx","title":"Investigate and optimize benchmark performance issues","description":"Investigation and optimization of CRDT library performance based on benchmark comparison with json-joy.\n\nKey findings from initial benchmarks:\n1. Binary decode shows suspiciously fast results (35M ops/sec) - needs verification\n2. Binary encoding is 3x slower than json-joy\n3. Binary codec produces 4x larger output than json-joy\n4. RGA sequential insert is O(n²) - 284ms for 10K chars\n\nTarget: Match or exceed json-joy performance given our more capable CPU.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-27T00:34:36.713327259+01:00","updated_at":"2025-12-27T00:47:00.530534521+01:00","closed_at":"2025-12-27T00:47:00.530534521+01:00","labels":["benchmarks","optimization","performance"]} 64 {"id":"crdt-z3n","title":"Add benchmark validation to ensure correctness","description":"Add validation steps to benchmarks:\n1. Verify encode/decode round-trip produces identical model\n2. Verify model view matches expected content\n3. Add checksums/hashes to detect corruption","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:35:03.801590973+01:00","updated_at":"2025-12-27T00:38:54.776020436+01:00","closed_at":"2025-12-27T00:38:54.776020436+01:00","labels":["benchmarks","testing"],"dependencies":[{"issue_id":"crdt-z3n","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:35:03.802861658+01:00","created_by":"gdiazlo"}]}
··· 56 {"id":"automerge-P8","title":"Phase 8: Conformance testing","description":"Implement full conformance test suite using json-crdt-traces fixtures plus fuzzing/property tests.","status":"open","priority":1,"issue_type":"epic","created_at":"2025-12-26T11:45:05.443231113+01:00","updated_at":"2025-12-26T11:45:05.443231113+01:00","labels":["conformance","epic","phase-8","testing"],"dependencies":[{"issue_id":"automerge-P8","depends_on_id":"automerge-P7","type":"parent-child","created_at":"2025-12-26T13:51:16.084904641+01:00","created_by":"gdiazlo"}]} 57 {"id":"crdt-4pq","title":"Fix RGA concurrent insert ordering for json-joy compatibility","description":"The RGA algorithm's tie-breaking for concurrent inserts doesn't match json-joy's implementation. When two replicas insert at the same position concurrently, the resulting order differs.\n\nEvidence from conformance tests:\n- Expected: \"An epic synopsis\" \n- Got: \"A synepic nopsis\" (the \"n\" from \"An\" appears in wrong position)\n\nNeed to analyze json-joy's RGA implementation and match its ordering rules:\n- Understand how json-joy determines concurrent inserts\n- Match tie-breaking logic for timestamp comparison\n- May need to track causal dependencies to determine concurrency","status":"closed","priority":1,"issue_type":"bug","assignee":"claude","created_at":"2025-12-26T17:19:31.628018647+01:00","updated_at":"2025-12-26T17:45:10.110299973+01:00","closed_at":"2025-12-26T17:45:10.110299973+01:00","labels":["conformance","crdt","json-joy","rga"]} 58 {"id":"crdt-4ra","title":"Reduce binary codec output size (currently 4x larger than json-joy)","description":"Binary output is 4.9KB vs json-joy's ~1.2KB for 1K chars.\nInvestigate:\n1. Timestamp encoding efficiency (delta encoding?)\n2. RGA chunk representation\n3. Node type encoding overhead\n4. Compare byte-by-byte with json-joy format","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-27T00:34:56.319523298+01:00","updated_at":"2025-12-27T09:29:04.871828606+01:00","closed_at":"2025-12-27T09:29:04.871828606+01:00","labels":["binary-codec","optimization","performance","size"],"dependencies":[{"issue_id":"crdt-4ra","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:34:56.320955254+01:00","created_by":"gdiazlo"}]} 59 + {"id":"crdt-68q","title":"Fix compact codec failing tests (friendsforever_flat)","description":"","status":"in_progress","priority":0,"issue_type":"bug","created_at":"2026-01-02T12:15:25.878861438+01:00","updated_at":"2026-01-02T12:15:34.21425901+01:00"} 60 + {"id":"crdt-6rt","title":"Fix remaining test failures after simdjsont migration","description":"","status":"in_progress","priority":0,"issue_type":"bug","assignee":"gdiazlo","created_at":"2026-01-02T11:36:44.354508505+01:00","updated_at":"2026-01-02T11:36:52.177356478+01:00"} 61 {"id":"crdt-7f0","title":"Optimize RGA sequential insert (O(n²) -\u003e O(n log n))","description":"Sequential insert of 10K chars takes 284ms - this is O(n²) behavior.\nOptions:\n1. Use tree-based structure (AVL, finger tree) instead of list\n2. Add index for fast position lookup\n3. Consider json-joy's B+tree approach\n\nTarget: \u003c 50ms for 10K sequential inserts","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:35:00.551809524+01:00","updated_at":"2025-12-27T00:46:27.873263358+01:00","closed_at":"2025-12-27T00:46:27.873263358+01:00","labels":["optimization","performance","rga"],"dependencies":[{"issue_id":"crdt-7f0","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:35:00.557418209+01:00","created_by":"gdiazlo"}]} 62 {"id":"crdt-9h3","title":"Optimize binary encoding performance (currently 3x slower than json-joy)","description":"Binary encoding is ~21K ops/sec vs json-joy's ~108K ops/sec.\nInvestigate:\n1. Buffer allocation strategy\n2. Varint encoding efficiency\n3. CBOR encoding overhead\n4. Consider pre-allocating buffers based on model size","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:34:52.454913078+01:00","updated_at":"2025-12-27T00:41:24.590935842+01:00","closed_at":"2025-12-27T00:41:24.590935842+01:00","labels":["binary-codec","optimization","performance"],"dependencies":[{"issue_id":"crdt-9h3","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:34:52.456412445+01:00","created_by":"gdiazlo"}]} 63 {"id":"crdt-9ry","title":"Run final benchmarks and compare with json-joy","description":"After all optimizations:\n1. Run full benchmark suite\n2. Verify all tests pass\n3. Document comparison with json-joy\n4. Target: exceed json-joy performance across all metrics","status":"closed","priority":2,"issue_type":"task","created_at":"2025-12-27T00:35:14.61471182+01:00","updated_at":"2025-12-27T00:46:58.828283923+01:00","closed_at":"2025-12-27T00:46:58.828283923+01:00","labels":["benchmarks","documentation"],"dependencies":[{"issue_id":"crdt-9ry","depends_on_id":"crdt-apw","type":"blocks","created_at":"2025-12-27T00:35:14.620794117+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-9h3","type":"blocks","created_at":"2025-12-27T00:35:14.621445689+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-4ra","type":"blocks","created_at":"2025-12-27T00:35:14.621869631+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-7f0","type":"blocks","created_at":"2025-12-27T00:35:14.622264163+01:00","created_by":"gdiazlo"},{"issue_id":"crdt-9ry","depends_on_id":"crdt-z3n","type":"blocks","created_at":"2025-12-27T00:35:14.622793455+01:00","created_by":"gdiazlo"}]} 64 {"id":"crdt-apw","title":"Investigate binary decode performance (35M ops/sec seems wrong)","description":"Binary decode shows 35M ops/sec which is suspiciously fast. Need to verify:\n1. The decode is actually doing work (not returning cached/memoized result)\n2. The decoded model is correct and usable\n3. Add validation that decoded model matches original","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:34:47.948086278+01:00","updated_at":"2025-12-27T00:38:53.472587773+01:00","closed_at":"2025-12-27T00:38:53.472587773+01:00","labels":["binary-codec","investigation","performance"],"dependencies":[{"issue_id":"crdt-apw","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:34:47.954081564+01:00","created_by":"gdiazlo"}]} 65 + {"id":"crdt-bwe","title":"Fix A decode_timestamp","description":"","status":"open","priority":1,"issue_type":"bug","created_at":"2026-01-02T12:06:12.866717163+01:00","updated_at":"2026-01-02T12:06:12.866717163+01:00"} 66 {"id":"crdt-icx","title":"Investigate and optimize benchmark performance issues","description":"Investigation and optimization of CRDT library performance based on benchmark comparison with json-joy.\n\nKey findings from initial benchmarks:\n1. Binary decode shows suspiciously fast results (35M ops/sec) - needs verification\n2. Binary encoding is 3x slower than json-joy\n3. Binary codec produces 4x larger output than json-joy\n4. RGA sequential insert is O(n²) - 284ms for 10K chars\n\nTarget: Match or exceed json-joy performance given our more capable CPU.","status":"closed","priority":1,"issue_type":"epic","created_at":"2025-12-27T00:34:36.713327259+01:00","updated_at":"2025-12-27T00:47:00.530534521+01:00","closed_at":"2025-12-27T00:47:00.530534521+01:00","labels":["benchmarks","optimization","performance"]} 67 {"id":"crdt-z3n","title":"Add benchmark validation to ensure correctness","description":"Add validation steps to benchmarks:\n1. Verify encode/decode round-trip produces identical model\n2. Verify model view matches expected content\n3. Add checksums/hashes to detect corruption","status":"closed","priority":1,"issue_type":"task","created_at":"2025-12-27T00:35:03.801590973+01:00","updated_at":"2025-12-27T00:38:54.776020436+01:00","closed_at":"2025-12-27T00:38:54.776020436+01:00","labels":["benchmarks","testing"],"dependencies":[{"issue_id":"crdt-z3n","depends_on_id":"crdt-icx","type":"blocks","created_at":"2025-12-27T00:35:03.802861658+01:00","created_by":"gdiazlo"}]}
+65
lib/json_compat.ml
···
··· 1 + module J = Simdjsont.Json 2 + 3 + type json = J.t 4 + type obj = (string * json) list 5 + type meta = unit 6 + 7 + let meta : meta = () 8 + let null : json = J.Null 9 + let bool (b : bool) : json = J.Bool b 10 + let number (f : float) : json = J.Float f 11 + let string (s : string) : json = J.String s 12 + let array (xs : json list) : json = J.Array xs 13 + let object_ (fields : obj) : json = J.Object fields 14 + let to_string (j : json) : string = J.to_string j 15 + let pp fmt j = Format.pp_print_string fmt (to_string j) 16 + 17 + let decode_string (s : string) : (json, string) result = 18 + Simdjsont.Decode.decode_string Simdjsont.Decode.value s 19 + 20 + let max_safe_int = 9007199254740991L 21 + let min_safe_int = -9007199254740991L 22 + 23 + let int_to_number (i : int) : json = 24 + let i64 = Int64.of_int i in 25 + if i64 >= min_safe_int && i64 <= max_safe_int then number (Float.of_int i) 26 + else J.Int i64 27 + 28 + let int64_to_number (i : int64) : json = 29 + if i >= min_safe_int && i <= max_safe_int then number (Int64.to_float i) 30 + else J.Int i 31 + 32 + let float_to_int_opt (f : float) : int option = 33 + if 34 + Float.is_integer f 35 + && f >= Float.of_int Int.min_int 36 + && f <= Float.of_int Int.max_int 37 + then Some (Float.to_int f) 38 + else None 39 + 40 + let get_number = function 41 + | J.Float f -> Ok f 42 + | J.Int i -> Ok (Int64.to_float i) 43 + | _ -> Error "expected number" 44 + 45 + let get_int = function 46 + | J.Float f -> ( 47 + match float_to_int_opt f with 48 + | Some i -> Ok i 49 + | None -> Error "expected integer") 50 + | J.Int i -> 51 + if i >= Int64.of_int Int.min_int && i <= Int64.of_int Int.max_int then 52 + Ok (Int64.to_int i) 53 + else Error "integer out of range" 54 + | _ -> Error "expected integer" 55 + 56 + let get_string = function J.String s -> Ok s | _ -> Error "expected string" 57 + let get_bool = function J.Bool b -> Ok b | _ -> Error "expected bool" 58 + let get_array = function J.Array xs -> Ok xs | _ -> Error "expected array" 59 + 60 + let get_object = function 61 + | J.Object fields -> Ok fields 62 + | _ -> Error "expected object" 63 + 64 + let obj_find (key : string) (fields : obj) : json option = 65 + List.find_map (fun (k, v) -> if k = key then Some v else None) fields
+358 -386
lib/model_codec_compact.ml
··· 20 - 5: bin (binary) 21 - 6: arr (array) *) 22 23 - let meta = Jsont.Meta.none 24 25 - (** Node type codes for compact format *) 26 let type_code_con = 0 27 - 28 let type_code_val = 1 29 let type_code_obj = 2 30 let type_code_vec = 3 31 let type_code_str = 4 32 let type_code_bin = 5 33 let type_code_arr = 6 34 35 type sid_table = { 36 - mutable sids : int list; (* List of session IDs in order *) 37 - mutable sid_to_idx : (int, int) Hashtbl.t; (* sid -> index (1-based) *) 38 } 39 - (** Session ID table for relative encoding. Maps session IDs to their index 40 - (1-based, negated for encoding). *) 41 42 let create_sid_table () = { sids = []; sid_to_idx = Hashtbl.create 16 } 43 ··· 50 Hashtbl.add table.sid_to_idx sid idx; 51 idx 52 53 - (** Encode a timestamp as [relative_sid_index, time]. The sid index is negated 54 - for the compact format. *) 55 - let encode_timestamp table (ts : Clock.timestamp) : Jsont.json = 56 let idx = get_or_add_sid table ts.sid in 57 - Jsont.Array 58 - ( [ 59 - Jsont.Number (Float.of_int (-idx), meta); 60 - Jsont.Number (Float.of_int ts.time, meta); 61 - ], 62 - meta ) 63 64 - (** Encode a Value.t to JSON for compact format *) 65 - let rec encode_value (v : Value.t) : Jsont.json = 66 match v with 67 - | Value.Null -> Jsont.Null ((), meta) 68 - | Value.Undefined -> 69 - Jsont.Number (0., meta) (* undefined encoded as 0 in compact con nodes *) 70 - | Value.Bool b -> Jsont.Bool (b, meta) 71 - | Value.Int i -> Jsont.Number (Float.of_int i, meta) 72 - | Value.Float f -> Jsont.Number (f, meta) 73 - | Value.String s -> Jsont.String (s, meta) 74 - | Value.Bytes b -> 75 - Jsont.String (Base64.encode_string (Bytes.to_string b), meta) 76 - | Value.Array arr -> Jsont.Array (List.map encode_value arr, meta) 77 | Value.Object pairs -> 78 - Jsont.Object 79 - (List.map (fun (k, v) -> ((k, meta), encode_value v)) pairs, meta) 80 | Value.Timestamp_ref (sid, time) -> 81 - (* Timestamp refs in values - just encode as array *) 82 - Jsont.Array 83 - ( [ 84 - Jsont.Number (Float.of_int sid, meta); 85 - Jsont.Number (Float.of_int time, meta); 86 - ], 87 - meta ) 88 89 - (** Encode string RGA chunks for compact format. Each chunk is 90 - [[relative_id, time], value_or_span] *) 91 - let encode_str_chunks table (rga : string Rga.t) : Jsont.json = 92 let chunks = 93 Rga.fold 94 (fun acc (chunk : string Rga.chunk) -> 95 let id_json = encode_timestamp table chunk.id in 96 let chunk_arr = 97 if chunk.deleted then 98 - (* Deleted chunk: [id, span] *) 99 - Jsont.Array 100 - ([ id_json; Jsont.Number (Float.of_int chunk.span, meta) ], meta) 101 - else 102 - (* Active chunk: [id, value] *) 103 - Jsont.Array ([ id_json; Jsont.String (chunk.data, meta) ], meta) 104 in 105 chunk_arr :: acc) 106 [] rga 107 in 108 - Jsont.Array (List.rev chunks, meta) 109 110 - (** Encode binary RGA chunks for compact format *) 111 - let encode_bin_chunks table (rga : bytes Rga.t) : Jsont.json = 112 let chunks = 113 Rga.fold 114 (fun acc (chunk : bytes Rga.chunk) -> 115 let id_json = encode_timestamp table chunk.id in 116 let chunk_arr = 117 if chunk.deleted then 118 - Jsont.Array 119 - ([ id_json; Jsont.Number (Float.of_int chunk.span, meta) ], meta) 120 else 121 let b64 = Base64.encode_string (Bytes.to_string chunk.data) in 122 - Jsont.Array ([ id_json; Jsont.String (b64, meta) ], meta) 123 in 124 chunk_arr :: acc) 125 [] rga 126 in 127 - Jsont.Array (List.rev chunks, meta) 128 129 - (** Encode array RGA chunks for compact format *) 130 - let rec encode_arr_chunks table model (rga : Clock.timestamp Rga.t) : Jsont.json 131 - = 132 let chunks = 133 Rga.fold 134 (fun acc (chunk : Clock.timestamp Rga.chunk) -> 135 let id_json = encode_timestamp table chunk.id in 136 let chunk_arr = 137 if chunk.deleted then 138 - Jsont.Array 139 - ([ id_json; Jsont.Number (Float.of_int chunk.span, meta) ], meta) 140 else 141 - (* Encode the referenced node inline *) 142 match Model.get_node model chunk.data with 143 | Some node -> 144 let node_json = encode_node table model node in 145 - Jsont.Array 146 - ([ id_json; Jsont.Array ([ node_json ], meta) ], meta) 147 - | None -> Jsont.Array ([ id_json; Jsont.Array ([], meta) ], meta) 148 in 149 chunk_arr :: acc) 150 [] rga 151 in 152 - Jsont.Array (List.rev chunks, meta) 153 154 - (** Encode a single node to compact format *) 155 - and encode_node table model (node : Node.t) : Jsont.json = 156 let id = Node.id node in 157 let id_json = encode_timestamp table id in 158 match node with 159 | Node.Node_con { con_value; _ } -> 160 - let type_code = Jsont.Number (Float.of_int type_code_con, meta) in 161 let value_json = encode_value con_value in 162 - (* con node: [0, id, value, 0] - the trailing 0 seems to be a flag *) 163 let is_undefined = 164 match con_value with Value.Undefined -> true | _ -> false 165 in 166 - if is_undefined then 167 - Jsont.Array 168 - ( [ 169 - type_code; 170 - id_json; 171 - Jsont.Number (0., meta); 172 - Jsont.Number (0., meta); 173 - ], 174 - meta ) 175 - else Jsont.Array ([ type_code; id_json; value_json ], meta) 176 | Node.Node_val { val_ref; _ } -> ( 177 - let type_code = Jsont.Number (Float.of_int type_code_val, meta) in 178 match val_ref with 179 - | None -> Jsont.Array ([ type_code; id_json ], meta) 180 | Some ref_ts -> ( 181 match Model.get_node model ref_ts with 182 | Some ref_node -> 183 let ref_json = encode_node table model ref_node in 184 - Jsont.Array ([ type_code; id_json; ref_json ], meta) 185 - | None -> Jsont.Array ([ type_code; id_json ], meta))) 186 | Node.Node_obj { obj_entries; _ } -> 187 - let type_code = Jsont.Number (Float.of_int type_code_obj, meta) in 188 let map_entries = 189 List.filter_map 190 (fun (entry : Node.obj_entry) -> 191 match Model.get_node model entry.obj_value with 192 | Some value_node -> 193 let value_json = encode_node table model value_node in 194 - Some ((entry.obj_key, meta), value_json) 195 | None -> None) 196 obj_entries 197 in 198 - Jsont.Array 199 - ([ type_code; id_json; Jsont.Object (map_entries, meta) ], meta) 200 | Node.Node_vec { vec_slots; _ } -> 201 - let type_code = Jsont.Number (Float.of_int type_code_vec, meta) in 202 let max_idx = 203 List.fold_left 204 (fun acc (s : Node.vec_slot) -> max acc s.vec_idx) ··· 207 let slots_arr = 208 if max_idx < 0 then [] 209 else begin 210 - let arr = Array.make (max_idx + 1) (Jsont.Null ((), meta)) in 211 List.iter 212 (fun (s : Node.vec_slot) -> 213 match Model.get_node model s.vec_value with ··· 217 Array.to_list arr 218 end 219 in 220 - Jsont.Array ([ type_code; id_json; Jsont.Array (slots_arr, meta) ], meta) 221 | Node.Node_str { str_rga; _ } -> 222 - let type_code = Jsont.Number (Float.of_int type_code_str, meta) in 223 - Jsont.Array ([ type_code; id_json; encode_str_chunks table str_rga ], meta) 224 | Node.Node_bin { bin_rga; _ } -> 225 - let type_code = Jsont.Number (Float.of_int type_code_bin, meta) in 226 - Jsont.Array ([ type_code; id_json; encode_bin_chunks table bin_rga ], meta) 227 | Node.Node_arr { arr_rga; _ } -> 228 - let type_code = Jsont.Number (Float.of_int type_code_arr, meta) in 229 - Jsont.Array 230 - ([ type_code; id_json; encode_arr_chunks table model arr_rga ], meta) 231 232 - (** Encode the clock vector as flat array [sid1, time1, sid2, time2, ...] *) 233 - let encode_clock_from_table table (cv : Clock.clock_vector) : Jsont.json = 234 - (* Add local clock to table first *) 235 let _ = get_or_add_sid table cv.local.clock_sid in 236 - (* Add all peers *) 237 List.iter 238 (fun (sid, _) -> 239 let _ = get_or_add_sid table sid in 240 ()) 241 cv.peers; 242 - (* Now encode: for each sid in table order, find its time *) 243 let entries = 244 List.concat_map 245 (fun sid -> ··· 247 if sid = cv.local.clock_sid then cv.local.clock_time 248 else match List.assoc_opt sid cv.peers with Some t -> t | None -> 0 249 in 250 - [ 251 - Jsont.Number (Float.of_int sid, meta); 252 - Jsont.Number (Float.of_int time, meta); 253 - ]) 254 table.sids 255 in 256 - Jsont.Array (entries, meta) 257 258 - (** Encode a complete model to compact JSON. Returns 259 - [clock_array, root_content_node] (root val is implicit) *) 260 - let encode (model : Model.t) : Jsont.json = 261 let table = create_sid_table () in 262 - (* First encode the content (to populate the sid table) *) 263 let content_json = 264 match model.root with 265 | Node.Node_val { val_ref = Some ref_ts; _ } -> ( 266 match Model.get_node model ref_ts with 267 | Some content_node -> encode_node table model content_node 268 - | None -> Jsont.Null ((), meta)) 269 - | _ -> Jsont.Null ((), meta) 270 in 271 - (* Now encode the clock with all SIDs that were referenced *) 272 let clock_json = encode_clock_from_table table model.clock in 273 - Jsont.Array ([ clock_json; content_json ], meta) 274 275 - (** Encode to JSON string *) 276 let encode_string ?(minify = true) model = 277 let json = encode model in 278 - if minify then Format.asprintf "%a" Jsont.pp_json json 279 - else Format.asprintf "%a" (Jsont.pp_json' ()) json 280 281 - (** {1 Compact Decoding} *) 282 - 283 - (** Decode a timestamp from [relative_sid_index, time] given the sid array *) 284 - let decode_timestamp sids (json : Jsont.json) : Clock.timestamp option = 285 match json with 286 - | Jsont.Array ([ Jsont.Number (idx_f, _); Jsont.Number (time_f, _) ], _) -> 287 - let idx = Float.to_int idx_f in 288 - let time = Float.to_int time_f in 289 - (* Index is negative in compact format, 1-based *) 290 - let sid_idx = -idx - 1 in 291 - if sid_idx >= 0 && sid_idx < Array.length sids then 292 - Some { Clock.sid = sids.(sid_idx); time } 293 - else None 294 | _ -> None 295 296 - (** Decode the clock vector from flat array [sid1, time1, sid2, time2, ...] *) 297 - let decode_clock (json : Jsont.json) : (int array * Clock.clock_vector) option = 298 match json with 299 - | Jsont.Array (entries, _) -> ( 300 let rec parse_pairs acc = function 301 | [] -> Some (List.rev acc) 302 - | Jsont.Number (sid_f, _) :: Jsont.Number (time_f, _) :: rest -> 303 parse_pairs ((Float.to_int sid_f, Float.to_int time_f) :: acc) rest 304 | _ -> None 305 in 306 match parse_pairs [] entries with ··· 315 | None -> None) 316 | _ -> None 317 318 - (** Decode a Value.t from compact JSON *) 319 - let rec decode_value (json : Jsont.json) : Value.t = 320 match json with 321 - | Jsont.Null _ -> Value.Null 322 - | Jsont.Bool (b, _) -> Value.Bool b 323 - | Jsont.Number (f, _) -> 324 if Float.is_integer f && Float.abs f < Float.of_int Int.max_int then 325 Value.Int (Float.to_int f) 326 else Value.Float f 327 - | Jsont.String (s, _) -> Value.String s 328 - | Jsont.Array (items, _) -> Value.Array (List.map decode_value items) 329 - | Jsont.Object (pairs, _) -> 330 - Value.Object (List.map (fun ((k, _), v) -> (k, decode_value v)) pairs) 331 332 - (** Decode a node from compact format and add to model *) 333 - let rec decode_node sids model (json : Jsont.json) : Clock.timestamp option = 334 match json with 335 - | Jsont.Array (Jsont.Number (type_code_f, _) :: id_json :: rest, _) -> ( 336 - let type_code = Float.to_int type_code_f in 337 - match decode_timestamp sids id_json with 338 - | Some id -> ( 339 match type_code with 340 - | 0 -> 341 - (* con *) 342 - let value = 343 - match rest with 344 - | [] -> Value.Undefined 345 - | [ Jsont.Number (0., _); Jsont.Number (0., _) ] -> 346 - Value.Undefined 347 - | [ Jsont.Number (0., _) ] -> Value.Undefined 348 - | [ v ] -> decode_value v 349 - | v :: _ -> decode_value v 350 - in 351 - let node = Node.make_con ~id ~value in 352 - Model.add_node model node; 353 - Some id 354 - | 1 -> 355 - (* val *) 356 - let node = Node.make_val ~id in 357 - Model.add_node model node; 358 - (match rest with 359 - | [ value_json ] -> ( 360 - match decode_node sids model value_json with 361 - | Some ref_id -> Node.set_val node ~value:ref_id 362 - | None -> ()) 363 - | _ -> ()); 364 - Some id 365 - | 2 -> 366 - (* obj *) 367 - let node = Node.make_obj ~id in 368 - Model.add_node model node; 369 - (match rest with 370 - | [ Jsont.Object (entries, _) ] -> 371 - List.iter 372 - (fun ((key, _), value_json) -> 373 - match decode_node sids model value_json with 374 - | Some value_id -> 375 - Node.set_obj_key node ~key ~value:value_id 376 - ~write_ts:value_id 377 - | None -> ()) 378 - entries 379 - | _ -> ()); 380 - Some id 381 - | 3 -> 382 - (* vec *) 383 - let node = Node.make_vec ~id in 384 - Model.add_node model node; 385 - (match rest with 386 - | [ Jsont.Array (slots, _) ] -> 387 - List.iteri 388 - (fun idx slot_json -> 389 - match slot_json with 390 - | Jsont.Null _ -> () 391 - | _ -> ( 392 - match decode_node sids model slot_json with 393 - | Some value_id -> 394 - Node.set_vec_slot node ~idx ~value:value_id 395 - ~write_ts:value_id 396 - | None -> ())) 397 - slots 398 - | _ -> ()); 399 - Some id 400 - | 4 -> 401 - (* str - build chunks directly from list *) 402 - let str_rga = 403 - match rest with 404 - | [ Jsont.Array (chunks, _) ] -> 405 - let decoded_chunks = 406 - List.filter_map 407 - (fun chunk_json -> 408 - match chunk_json with 409 - | Jsont.Array ([ chunk_id_json; value_or_span ], _) 410 - -> ( 411 - match decode_timestamp sids chunk_id_json with 412 - | Some chunk_id -> ( 413 - match value_or_span with 414 - | Jsont.String (s, _) -> 415 - Some 416 - { 417 - Rga.id = chunk_id; 418 - span = String.length s; 419 - data = s; 420 - deleted = false; 421 - parent = None; 422 - } 423 - | Jsont.Number (span_f, _) -> 424 - let span = Float.to_int span_f in 425 - Some 426 - { 427 - Rga.id = chunk_id; 428 - span; 429 - data = String.make span ' '; 430 - deleted = true; 431 - parent = None; 432 - } 433 - | _ -> None) 434 - | None -> None) 435 - | _ -> None) 436 - chunks 437 - in 438 - Rga.from_chunks decoded_chunks 439 - | _ -> Rga.empty () 440 - in 441 - let node = Node.Node_str { str_id = id; str_rga } in 442 - Model.add_node model node; 443 - Some id 444 - | 5 -> 445 - (* bin - build chunks directly from list *) 446 - let bin_rga = 447 - match rest with 448 - | [ Jsont.Array (chunks, _) ] -> 449 - let decoded_chunks = 450 - List.filter_map 451 - (fun chunk_json -> 452 - match chunk_json with 453 - | Jsont.Array ([ chunk_id_json; value_or_span ], _) 454 - -> ( 455 - match decode_timestamp sids chunk_id_json with 456 - | Some chunk_id -> ( 457 - match value_or_span with 458 - | Jsont.String (s, _) -> ( 459 - match Base64.decode s with 460 - | Ok decoded -> 461 - let data = Bytes.of_string decoded in 462 - Some 463 - { 464 - Rga.id = chunk_id; 465 - span = Bytes.length data; 466 - data; 467 - deleted = false; 468 - parent = None; 469 - } 470 - | Error _ -> None) 471 - | Jsont.Number (span_f, _) -> 472 - let span = Float.to_int span_f in 473 - Some 474 - { 475 - Rga.id = chunk_id; 476 - span; 477 - data = Bytes.make span '\x00'; 478 - deleted = true; 479 - parent = None; 480 - } 481 - | _ -> None) 482 - | None -> None) 483 - | _ -> None) 484 - chunks 485 - in 486 - Rga.from_chunks decoded_chunks 487 - | _ -> Rga.empty () 488 - in 489 - let node = Node.Node_bin { bin_id = id; bin_rga } in 490 - Model.add_node model node; 491 - Some id 492 - | 6 -> 493 - (* arr *) 494 - let node = Node.make_arr ~id in 495 - Model.add_node model node; 496 - (match rest with 497 - | [ Jsont.Array (chunks, _) ] -> 498 - List.iter 499 - (fun chunk_json -> 500 - match chunk_json with 501 - | Jsont.Array ([ chunk_id_json; value_json ], _) -> ( 502 - match decode_timestamp sids chunk_id_json with 503 - | Some chunk_id -> ( 504 - match value_json with 505 - | Jsont.Array ([ elem_json ], _) -> ( 506 - (* Single element in value array *) 507 - match decode_node sids model elem_json with 508 - | Some elem_id -> 509 - let after = 510 - match node with 511 - | Node.Node_arr { arr_rga; _ } -> 512 - Rga.find_last_id arr_rga 513 - | _ -> None 514 - in 515 - Node.insert_arr node ~after ~chunk_id 516 - ~value:elem_id 517 - | None -> ()) 518 - | Jsont.Array (elements, _) -> 519 - (* Multiple elements *) 520 - List.iteri 521 - (fun i elem_json -> 522 - match 523 - decode_node sids model elem_json 524 - with 525 - | Some elem_id -> 526 - let after = 527 - match node with 528 - | Node.Node_arr { arr_rga; _ } -> 529 - Rga.find_last_id arr_rga 530 - | _ -> None 531 - in 532 - let slot_id = 533 - { 534 - chunk_id with 535 - Clock.time = 536 - chunk_id.Clock.time + i; 537 - } 538 - in 539 - Node.insert_arr node ~after 540 - ~chunk_id:slot_id ~value:elem_id 541 - | None -> ()) 542 - elements 543 - | Jsont.Number (span_f, _) -> 544 - (* Deleted chunk *) 545 - let span = Float.to_int span_f in 546 - let after = 547 - match node with 548 - | Node.Node_arr { arr_rga; _ } -> 549 - Rga.find_last_id arr_rga 550 - | _ -> None 551 - in 552 - Node.insert_arr node ~after ~chunk_id 553 - ~value:chunk_id; 554 - Node.delete_range node 555 - ~spans: 556 - [ 557 - { 558 - sid = chunk_id.sid; 559 - time = chunk_id.time; 560 - span; 561 - }; 562 - ] 563 - | _ -> ()) 564 - | None -> ()) 565 - | _ -> ()) 566 - chunks 567 - | _ -> ()); 568 - Some id 569 | _ -> None) 570 - | None -> None) 571 | _ -> None 572 573 - (** Decode a complete model from compact JSON *) 574 - let decode (json : Jsont.json) : Model.t option = 575 match json with 576 - | Jsont.Array ([ clock_json; content_json ], _) -> ( 577 match decode_clock clock_json with 578 | Some (sids, clock) -> 579 let model = Model.create clock.local.clock_sid in 580 model.clock.local.clock_time <- clock.local.clock_time; 581 model.clock.peers <- clock.peers; 582 - (* Decode the content node and set as root's value *) 583 - (match decode_node sids model content_json with 584 - | Some ref_id -> Node.set_val model.root ~value:ref_id 585 - | None -> ()); 586 Some model 587 | None -> None) 588 | _ -> None 589 590 - (** Decode from JSON string *) 591 let decode_string s = 592 - match Jsont_bytesrw.decode_string Jsont.json s with 593 | Ok json -> decode json 594 | Error e -> 595 Printf.eprintf "JSON parse error: %s\n" e;
··· 20 - 5: bin (binary) 21 - 6: arr (array) *) 22 23 + module J = Simdjsont.Json 24 25 let type_code_con = 0 26 let type_code_val = 1 27 let type_code_obj = 2 28 let type_code_vec = 3 29 let type_code_str = 4 30 let type_code_bin = 5 31 let type_code_arr = 6 32 + let string_span (s : string) : int = String.length s 33 + let bytes_span (b : bytes) : int = Bytes.length b 34 35 type sid_table = { 36 + mutable sids : int list; 37 + mutable sid_to_idx : (int, int) Hashtbl.t; 38 } 39 40 let create_sid_table () = { sids = []; sid_to_idx = Hashtbl.create 16 } 41 ··· 48 Hashtbl.add table.sid_to_idx sid idx; 49 idx 50 51 + let encode_timestamp table (ts : Clock.timestamp) : J.t = 52 let idx = get_or_add_sid table ts.sid in 53 + J.Array [ J.Int (Int64.of_int (-idx)); J.Int (Int64.of_int ts.time) ] 54 55 + let rec encode_value (v : Value.t) : J.t = 56 match v with 57 + | Value.Null -> J.Null 58 + | Value.Undefined -> J.Int 0L 59 + | Value.Bool b -> J.Bool b 60 + | Value.Int i -> J.Int (Int64.of_int i) 61 + | Value.Float f -> J.Float f 62 + | Value.String s -> J.String s 63 + | Value.Bytes b -> J.String (Base64.encode_string (Bytes.to_string b)) 64 + | Value.Array arr -> J.Array (List.map encode_value arr) 65 | Value.Object pairs -> 66 + J.Object (List.map (fun (k, v) -> (k, encode_value v)) pairs) 67 | Value.Timestamp_ref (sid, time) -> 68 + J.Array [ J.Int (Int64.of_int sid); J.Int (Int64.of_int time) ] 69 70 + let encode_str_chunks table (rga : string Rga.t) : J.t = 71 let chunks = 72 Rga.fold 73 (fun acc (chunk : string Rga.chunk) -> 74 let id_json = encode_timestamp table chunk.id in 75 let chunk_arr = 76 if chunk.deleted then 77 + J.Array [ id_json; J.Float (Float.of_int chunk.span) ] 78 + else J.Array [ id_json; J.String chunk.data ] 79 in 80 chunk_arr :: acc) 81 [] rga 82 in 83 + J.Array (List.rev chunks) 84 85 + let encode_bin_chunks table (rga : bytes Rga.t) : J.t = 86 let chunks = 87 Rga.fold 88 (fun acc (chunk : bytes Rga.chunk) -> 89 let id_json = encode_timestamp table chunk.id in 90 let chunk_arr = 91 if chunk.deleted then 92 + J.Array [ id_json; J.Float (Float.of_int chunk.span) ] 93 else 94 let b64 = Base64.encode_string (Bytes.to_string chunk.data) in 95 + J.Array [ id_json; J.String b64 ] 96 in 97 chunk_arr :: acc) 98 [] rga 99 in 100 + J.Array (List.rev chunks) 101 102 + let rec encode_arr_chunks table model (rga : Clock.timestamp Rga.t) : J.t = 103 let chunks = 104 Rga.fold 105 (fun acc (chunk : Clock.timestamp Rga.chunk) -> 106 let id_json = encode_timestamp table chunk.id in 107 let chunk_arr = 108 if chunk.deleted then 109 + J.Array [ id_json; J.Float (Float.of_int chunk.span) ] 110 else 111 match Model.get_node model chunk.data with 112 | Some node -> 113 let node_json = encode_node table model node in 114 + J.Array [ id_json; J.Array [ node_json ] ] 115 + | None -> J.Array [ id_json; J.Array [] ] 116 in 117 chunk_arr :: acc) 118 [] rga 119 in 120 + J.Array (List.rev chunks) 121 122 + and encode_node table model (node : Node.t) : J.t = 123 let id = Node.id node in 124 let id_json = encode_timestamp table id in 125 match node with 126 | Node.Node_con { con_value; _ } -> 127 + let type_code = J.Int (Int64.of_int type_code_con) in 128 let value_json = encode_value con_value in 129 let is_undefined = 130 match con_value with Value.Undefined -> true | _ -> false 131 in 132 + if is_undefined then J.Array [ type_code; id_json; J.Int 0L; J.Int 0L ] 133 + else J.Array [ type_code; id_json; value_json ] 134 | Node.Node_val { val_ref; _ } -> ( 135 + let type_code = J.Int (Int64.of_int type_code_val) in 136 match val_ref with 137 + | None -> J.Array [ type_code; id_json ] 138 | Some ref_ts -> ( 139 match Model.get_node model ref_ts with 140 | Some ref_node -> 141 let ref_json = encode_node table model ref_node in 142 + J.Array [ type_code; id_json; ref_json ] 143 + | None -> J.Array [ type_code; id_json ])) 144 | Node.Node_obj { obj_entries; _ } -> 145 + let type_code = J.Int (Int64.of_int type_code_obj) in 146 let map_entries = 147 List.filter_map 148 (fun (entry : Node.obj_entry) -> 149 match Model.get_node model entry.obj_value with 150 | Some value_node -> 151 let value_json = encode_node table model value_node in 152 + Some (entry.obj_key, value_json) 153 | None -> None) 154 obj_entries 155 in 156 + J.Array [ type_code; id_json; J.Object map_entries ] 157 | Node.Node_vec { vec_slots; _ } -> 158 + let type_code = J.Int (Int64.of_int type_code_vec) in 159 let max_idx = 160 List.fold_left 161 (fun acc (s : Node.vec_slot) -> max acc s.vec_idx) ··· 164 let slots_arr = 165 if max_idx < 0 then [] 166 else begin 167 + let arr = Array.make (max_idx + 1) J.Null in 168 List.iter 169 (fun (s : Node.vec_slot) -> 170 match Model.get_node model s.vec_value with ··· 174 Array.to_list arr 175 end 176 in 177 + J.Array [ type_code; id_json; J.Array slots_arr ] 178 | Node.Node_str { str_rga; _ } -> 179 + let type_code = J.Int (Int64.of_int type_code_str) in 180 + J.Array [ type_code; id_json; encode_str_chunks table str_rga ] 181 | Node.Node_bin { bin_rga; _ } -> 182 + let type_code = J.Int (Int64.of_int type_code_bin) in 183 + J.Array [ type_code; id_json; encode_bin_chunks table bin_rga ] 184 | Node.Node_arr { arr_rga; _ } -> 185 + let type_code = J.Int (Int64.of_int type_code_arr) in 186 + J.Array [ type_code; id_json; encode_arr_chunks table model arr_rga ] 187 188 + let encode_clock_from_table table (cv : Clock.clock_vector) : J.t = 189 let _ = get_or_add_sid table cv.local.clock_sid in 190 List.iter 191 (fun (sid, _) -> 192 let _ = get_or_add_sid table sid in 193 ()) 194 cv.peers; 195 let entries = 196 List.concat_map 197 (fun sid -> ··· 199 if sid = cv.local.clock_sid then cv.local.clock_time 200 else match List.assoc_opt sid cv.peers with Some t -> t | None -> 0 201 in 202 + [ J.Int (Int64.of_int sid); J.Int (Int64.of_int time) ]) 203 table.sids 204 in 205 + J.Array entries 206 207 + let encode (model : Model.t) : J.t = 208 let table = create_sid_table () in 209 let content_json = 210 match model.root with 211 | Node.Node_val { val_ref = Some ref_ts; _ } -> ( 212 match Model.get_node model ref_ts with 213 | Some content_node -> encode_node table model content_node 214 + | None -> J.Null) 215 + | _ -> J.Null 216 in 217 let clock_json = encode_clock_from_table table model.clock in 218 + J.Array [ clock_json; content_json ] 219 220 let encode_string ?(minify = true) model = 221 let json = encode model in 222 + let _ = minify in 223 + J.to_string json 224 225 + let decode_timestamp sids (json : J.t) : Clock.timestamp option = 226 + let int_of_json (json : J.t) : int option = 227 + match json with 228 + | J.Int i -> Some (Int64.to_int i) 229 + | J.Float f -> Some (Float.to_int f) 230 + | _ -> None 231 + in 232 match json with 233 + | J.Array [ idx_json; time_json ] -> ( 234 + match (int_of_json idx_json, int_of_json time_json) with 235 + | Some idx, Some time -> 236 + if idx < 0 then 237 + let sid_idx = -idx - 1 in 238 + if sid_idx >= 0 && sid_idx < Array.length sids then 239 + Some { Clock.sid = sids.(sid_idx); time } 240 + else None 241 + else Some { Clock.sid = idx; time } 242 + | _ -> None) 243 | _ -> None 244 245 + let decode_clock (json : J.t) : (int array * Clock.clock_vector) option = 246 match json with 247 + | J.Array entries -> ( 248 let rec parse_pairs acc = function 249 | [] -> Some (List.rev acc) 250 + | J.Float sid_f :: J.Float time_f :: rest -> 251 parse_pairs ((Float.to_int sid_f, Float.to_int time_f) :: acc) rest 252 + | J.Int sid_i :: J.Int time_i :: rest -> 253 + parse_pairs ((Int64.to_int sid_i, Int64.to_int time_i) :: acc) rest 254 | _ -> None 255 in 256 match parse_pairs [] entries with ··· 265 | None -> None) 266 | _ -> None 267 268 + let rec decode_value (json : J.t) : Value.t = 269 match json with 270 + | J.Null -> Value.Null 271 + | J.Bool b -> Value.Bool b 272 + | J.Float f -> 273 if Float.is_integer f && Float.abs f < Float.of_int Int.max_int then 274 Value.Int (Float.to_int f) 275 else Value.Float f 276 + | J.Int i -> 277 + if Int64.equal i 0L then Value.Undefined else Value.Int (Int64.to_int i) 278 + | J.String s -> Value.String s 279 + | J.Array items -> Value.Array (List.map decode_value items) 280 + | J.Object pairs -> 281 + Value.Object (List.map (fun (k, v) -> (k, decode_value v)) pairs) 282 283 + let rec decode_node sids model (json : J.t) : Clock.timestamp option = 284 + let int_of_json (json : J.t) : int option = 285 + match json with 286 + | J.Int i -> Some (Int64.to_int i) 287 + | J.Float f -> Some (Float.to_int f) 288 + | _ -> None 289 + in 290 + let decode_con id rest = 291 + let value = 292 + match rest with 293 + | [] -> Value.Undefined 294 + | [ J.Int 0L; J.Int 0L ] -> Value.Undefined 295 + | [ J.Float 0.; J.Float 0. ] -> Value.Undefined 296 + | [ J.Int 0L ] -> Value.Undefined 297 + | [ J.Float 0. ] -> Value.Undefined 298 + | [ v ] -> decode_value v 299 + | v :: _ -> decode_value v 300 + in 301 + let node = Node.make_con ~id ~value in 302 + Model.add_node model node; 303 + Some id 304 + in 305 + let decode_val id rest = 306 + let node = Node.make_val ~id in 307 + Model.add_node model node; 308 + (match rest with 309 + | [ value_json ] -> ( 310 + match decode_node sids model value_json with 311 + | Some ref_id -> Node.set_val node ~value:ref_id 312 + | None -> ()) 313 + | _ -> ()); 314 + Some id 315 + in 316 + let decode_obj id rest = 317 + let node = Node.make_obj ~id in 318 + Model.add_node model node; 319 + (match rest with 320 + | [ J.Object entries ] -> 321 + List.iter 322 + (fun (key, value_json) -> 323 + match decode_node sids model value_json with 324 + | Some value_id -> 325 + Node.set_obj_key node ~key ~value:value_id ~write_ts:value_id 326 + | None -> ()) 327 + entries 328 + | _ -> ()); 329 + Some id 330 + in 331 + let decode_vec id rest = 332 + let node = Node.make_vec ~id in 333 + Model.add_node model node; 334 + (match rest with 335 + | [ J.Array slots ] -> 336 + List.iteri 337 + (fun idx slot_json -> 338 + match slot_json with 339 + | J.Null -> () 340 + | _ -> ( 341 + match decode_node sids model slot_json with 342 + | Some value_id -> 343 + Node.set_vec_slot node ~idx ~value:value_id 344 + ~write_ts:value_id 345 + | None -> ())) 346 + slots 347 + | _ -> ()); 348 + Some id 349 + in 350 + let decode_str id rest = 351 + let rec build_chunks acc parent = function 352 + | [] -> List.rev acc 353 + | J.Array [ chunk_id_json; value_or_span ] :: rest_chunks -> ( 354 + match decode_timestamp sids chunk_id_json with 355 + | None -> build_chunks acc parent rest_chunks 356 + | Some chunk_id -> ( 357 + match value_or_span with 358 + | J.String text -> 359 + let span = String.length text in 360 + let chunk : string Rga.chunk = 361 + { 362 + id = chunk_id; 363 + span; 364 + data = text; 365 + deleted = false; 366 + parent; 367 + } 368 + in 369 + let last = 370 + Some 371 + { 372 + chunk_id with 373 + Clock.time = chunk_id.Clock.time + span - 1; 374 + } 375 + in 376 + build_chunks (chunk :: acc) last rest_chunks 377 + | _ -> ( 378 + match int_of_json value_or_span with 379 + | None -> build_chunks acc parent rest_chunks 380 + | Some span -> 381 + let chunk : string Rga.chunk = 382 + { 383 + id = chunk_id; 384 + span; 385 + data = String.make span '\x00'; 386 + deleted = true; 387 + parent; 388 + } 389 + in 390 + let last = 391 + Some 392 + { 393 + chunk_id with 394 + Clock.time = chunk_id.Clock.time + span - 1; 395 + } 396 + in 397 + build_chunks (chunk :: acc) last rest_chunks))) 398 + | _ :: rest_chunks -> build_chunks acc parent rest_chunks 399 + in 400 + let str_rga = 401 + match rest with 402 + | [ J.Array chunks ] -> Rga.from_chunks (build_chunks [] None chunks) 403 + | _ -> Rga.empty () 404 + in 405 + let node = Node.Node_str { str_id = id; str_rga } in 406 + Model.add_node model node; 407 + Some id 408 + in 409 + let decode_bin id rest = 410 + let rec build_chunks acc parent = function 411 + | [] -> List.rev acc 412 + | J.Array [ chunk_id_json; value_or_span ] :: rest_chunks -> ( 413 + match decode_timestamp sids chunk_id_json with 414 + | None -> build_chunks acc parent rest_chunks 415 + | Some chunk_id -> ( 416 + match value_or_span with 417 + | J.String s -> ( 418 + match Base64.decode s with 419 + | Error _ -> build_chunks acc parent rest_chunks 420 + | Ok decoded -> 421 + let data = Bytes.of_string decoded in 422 + let span = Bytes.length data in 423 + let chunk : bytes Rga.chunk = 424 + { id = chunk_id; span; data; deleted = false; parent } 425 + in 426 + let last = 427 + Some 428 + { 429 + chunk_id with 430 + Clock.time = chunk_id.Clock.time + span - 1; 431 + } 432 + in 433 + build_chunks (chunk :: acc) last rest_chunks) 434 + | _ -> ( 435 + match int_of_json value_or_span with 436 + | None -> build_chunks acc parent rest_chunks 437 + | Some span -> 438 + let chunk : bytes Rga.chunk = 439 + { 440 + id = chunk_id; 441 + span; 442 + data = Bytes.make span '\x00'; 443 + deleted = true; 444 + parent; 445 + } 446 + in 447 + let last = 448 + Some 449 + { 450 + chunk_id with 451 + Clock.time = chunk_id.Clock.time + span - 1; 452 + } 453 + in 454 + build_chunks (chunk :: acc) last rest_chunks))) 455 + | _ :: rest_chunks -> build_chunks acc parent rest_chunks 456 + in 457 + let bin_rga = 458 + match rest with 459 + | [ J.Array chunks ] -> Rga.from_chunks (build_chunks [] None chunks) 460 + | _ -> Rga.empty () 461 + in 462 + let node = Node.Node_bin { bin_id = id; bin_rga } in 463 + Model.add_node model node; 464 + Some id 465 + in 466 + let decode_arr id rest = 467 + let node = Node.make_arr ~id in 468 + Model.add_node model node; 469 + (match rest with 470 + | [ J.Array chunks ] -> 471 + List.iter 472 + (fun chunk_json -> 473 + match chunk_json with 474 + | J.Array [ chunk_id_json; value_json ] -> ( 475 + match decode_timestamp sids chunk_id_json with 476 + | Some chunk_id -> ( 477 + match value_json with 478 + | J.Array [ elem_json ] -> ( 479 + match decode_node sids model elem_json with 480 + | Some elem_id -> 481 + let after = 482 + match node with 483 + | Node.Node_arr { arr_rga; _ } -> 484 + Rga.find_last_id arr_rga 485 + | _ -> None 486 + in 487 + Node.insert_arr node ~after ~chunk_id ~value:elem_id 488 + | None -> ()) 489 + | J.Array elements -> 490 + List.iteri 491 + (fun i elem_json -> 492 + match decode_node sids model elem_json with 493 + | Some elem_id -> 494 + let after = 495 + match node with 496 + | Node.Node_arr { arr_rga; _ } -> 497 + Rga.find_last_id arr_rga 498 + | _ -> None 499 + in 500 + let slot_id = 501 + { 502 + chunk_id with 503 + Clock.time = chunk_id.Clock.time + i; 504 + } 505 + in 506 + Node.insert_arr node ~after ~chunk_id:slot_id 507 + ~value:elem_id 508 + | None -> ()) 509 + elements 510 + | span_json -> ( 511 + match int_of_json span_json with 512 + | Some span -> 513 + Node.delete_range node 514 + ~spans: 515 + [ 516 + { 517 + sid = chunk_id.sid; 518 + time = chunk_id.time; 519 + span; 520 + }; 521 + ] 522 + | None -> ())) 523 + | None -> ()) 524 + | _ -> ()) 525 + chunks 526 + | _ -> ()); 527 + Some id 528 + in 529 match json with 530 + | J.Array (type_code_json :: id_json :: rest) -> ( 531 + match (int_of_json type_code_json, decode_timestamp sids id_json) with 532 + | Some type_code, Some id -> ( 533 match type_code with 534 + | 0 -> decode_con id rest 535 + | 1 -> decode_val id rest 536 + | 2 -> decode_obj id rest 537 + | 3 -> decode_vec id rest 538 + | 4 -> decode_str id rest 539 + | 5 -> decode_bin id rest 540 + | 6 -> decode_arr id rest 541 | _ -> None) 542 + | _ -> None) 543 | _ -> None 544 545 + let decode (json : J.t) : Model.t option = 546 match json with 547 + | J.Array [ clock_json; content_json ] -> ( 548 match decode_clock clock_json with 549 | Some (sids, clock) -> 550 let model = Model.create clock.local.clock_sid in 551 model.clock.local.clock_time <- clock.local.clock_time; 552 model.clock.peers <- clock.peers; 553 + (match content_json with 554 + | J.Null -> () 555 + | _ -> ( 556 + match decode_node sids model content_json with 557 + | Some content_id -> Node.set_val model.root ~value:content_id 558 + | None -> ())); 559 Some model 560 | None -> None) 561 | _ -> None 562 563 let decode_string s = 564 + match Simdjsont.Decode.decode_string Simdjsont.Decode.value s with 565 | Ok json -> decode json 566 | Error e -> 567 Printf.eprintf "JSON parse error: %s\n" e;
+373 -218
lib/patch_codec_compact.ml
··· 26 - 16: del 27 - 17: nop *) 28 29 - (** {1 Compact Opcodes} *) 30 31 - (** Compact opcode values (different from verbose op names!) *) 32 let compact_opcode_of_op = function 33 | Op.Op_new_con _ -> 0 34 | Op.Op_new_val -> 1 ··· 47 | Op.Op_del _ -> 16 48 | Op.Op_nop _ -> 17 49 50 - (** {1 Helpers} *) 51 - 52 - let meta = Jsont.Meta.none 53 54 - (** Encode a timestamp. If session matches patch session, just encode time. 55 - Otherwise encode as [sid, time]. *) 56 - let encode_ts ~patch_sid (ts : Clock.timestamp) : Jsont.json = 57 - if ts.sid = patch_sid then Jsont.Number (Float.of_int ts.time, meta) 58 - else 59 - Jsont.Array 60 - ( [ 61 - Jsont.Number (Float.of_int ts.sid, meta); 62 - Jsont.Number (Float.of_int ts.time, meta); 63 - ], 64 - meta ) 65 - 66 - (** Encode a timespan as [time, span] or [[sid, time], span] *) 67 - let encode_timespan ~patch_sid (ts : Clock.timespan) : Jsont.json = 68 if ts.sid = patch_sid then 69 - Jsont.Array 70 - ( [ 71 - Jsont.Number (Float.of_int ts.time, meta); 72 - Jsont.Number (Float.of_int ts.span, meta); 73 - ], 74 - meta ) 75 else 76 - Jsont.Array 77 - ( [ 78 - Jsont.Array 79 - ( [ 80 - Jsont.Number (Float.of_int ts.sid, meta); 81 - Jsont.Number (Float.of_int ts.time, meta); 82 - ], 83 - meta ); 84 - Jsont.Number (Float.of_int ts.span, meta); 85 - ], 86 - meta ) 87 88 - (** Encode a value for new_con *) 89 - let encode_con_value (v : Value.t) : Jsont.json = 90 match v with 91 - | Value.Null -> Jsont.Null ((), meta) 92 - | Value.Bool b -> Jsont.Bool (b, meta) 93 - | Value.Int n -> Jsont.Number (Float.of_int n, meta) 94 - | Value.Float f -> Jsont.Number (f, meta) 95 - | Value.String s -> Jsont.String (s, meta) 96 - | _ -> Jsont.Null ((), meta) 97 - 98 - (** {1 Operation Encoding} *) 99 100 - (** Encode an operation in compact format *) 101 - let encode_op ~patch_sid (op : Op.op_data) : Jsont.json = 102 - let opcode = Jsont.Number (Float.of_int (compact_opcode_of_op op), meta) in 103 match op with 104 | Op.Op_new_con { con_value } -> 105 - Jsont.Array ([ opcode; encode_con_value con_value ], meta) 106 | Op.Op_new_val | Op.Op_new_obj | Op.Op_new_vec | Op.Op_new_str 107 | Op.Op_new_bin | Op.Op_new_arr -> 108 - Jsont.Array ([ opcode ], meta) 109 | Op.Op_ins_val { ins_val_obj; ins_val_value } -> 110 - Jsont.Array 111 - ( [ 112 - opcode; 113 - encode_ts ~patch_sid ins_val_obj; 114 - encode_ts ~patch_sid ins_val_value; 115 - ], 116 - meta ) 117 | Op.Op_ins_obj { ins_obj_obj; ins_obj_value } -> 118 let entries = 119 List.map 120 - (fun (key, ts) -> 121 - Jsont.Array 122 - ([ Jsont.String (key, meta); encode_ts ~patch_sid ts ], meta)) 123 ins_obj_value 124 in 125 - Jsont.Array 126 - ( [ 127 - opcode; encode_ts ~patch_sid ins_obj_obj; Jsont.Array (entries, meta); 128 - ], 129 - meta ) 130 | Op.Op_ins_vec { ins_vec_obj; ins_vec_idx; ins_vec_value } -> 131 - Jsont.Array 132 - ( [ 133 - opcode; 134 - encode_ts ~patch_sid ins_vec_obj; 135 - Jsont.Number (Float.of_int ins_vec_idx, meta); 136 - encode_ts ~patch_sid ins_vec_value; 137 - ], 138 - meta ) 139 | Op.Op_ins_str { ins_str_obj; ins_str_after; ins_str_value } -> 140 - Jsont.Array 141 - ( [ 142 - opcode; 143 - encode_ts ~patch_sid ins_str_obj; 144 - encode_ts ~patch_sid ins_str_after; 145 - Jsont.String (ins_str_value, meta); 146 - ], 147 - meta ) 148 | Op.Op_ins_bin { ins_bin_obj; ins_bin_after; ins_bin_value } -> 149 - Jsont.Array 150 - ( [ 151 - opcode; 152 - encode_ts ~patch_sid ins_bin_obj; 153 - encode_ts ~patch_sid ins_bin_after; 154 - Jsont.String 155 - (Base64.encode_string (Bytes.to_string ins_bin_value), meta); 156 - ], 157 - meta ) 158 | Op.Op_ins_arr { ins_arr_obj; ins_arr_after; ins_arr_value } -> 159 - Jsont.Array 160 - ( [ 161 - opcode; 162 - encode_ts ~patch_sid ins_arr_obj; 163 - encode_ts ~patch_sid ins_arr_after; 164 - encode_ts ~patch_sid ins_arr_value; 165 - ], 166 - meta ) 167 | Op.Op_upd_arr { upd_arr_obj; upd_arr_pos; upd_arr_value } -> 168 - Jsont.Array 169 - ( [ 170 - opcode; 171 - encode_ts ~patch_sid upd_arr_obj; 172 - encode_ts ~patch_sid upd_arr_pos; 173 - encode_ts ~patch_sid upd_arr_value; 174 - ], 175 - meta ) 176 | Op.Op_del { del_obj; del_what } -> 177 let spans = List.map (encode_timespan ~patch_sid) del_what in 178 - Jsont.Array 179 - ( [ opcode; encode_ts ~patch_sid del_obj; Jsont.Array (spans, meta) ], 180 - meta ) 181 | Op.Op_nop { nop_len } -> 182 - if nop_len = 1 then Jsont.Array ([ opcode ], meta) 183 - else 184 - Jsont.Array ([ opcode; Jsont.Number (Float.of_int nop_len, meta) ], meta) 185 186 - (** {1 Patch Encoding} *) 187 - 188 - (** Encode a patch to compact JSON *) 189 - let encode_patch_json (patch : Patch.t) : Jsont.json = 190 let patch_sid = patch.id.sid in 191 let id_json = 192 - Jsont.Array 193 - ( [ 194 - Jsont.Array 195 - ( [ 196 - Jsont.Number (Float.of_int patch.id.sid, meta); 197 - Jsont.Number (Float.of_int patch.id.time, meta); 198 - ], 199 - meta ); 200 - ], 201 - meta ) 202 in 203 let ops_json = List.map (encode_op ~patch_sid) patch.ops in 204 - Jsont.Array (id_json :: ops_json, meta) 205 206 - (** Encode a patch to a compact JSON string *) 207 let encode (patch : Patch.t) : string = 208 let json = encode_patch_json patch in 209 - Format.asprintf "%a" Jsont.pp_json json 210 211 - (** Encode a patch to a pretty-printed JSON string *) 212 let encode_pretty (patch : Patch.t) : string = 213 let json = encode_patch_json patch in 214 - Format.asprintf "%a" (Jsont.pp_json' ()) json 215 - 216 - (** {1 Decoding Helpers} *) 217 218 - (** Decode a timestamp. Can be either just a number (time) or [sid, time] array. 219 - *) 220 - let decode_ts ~patch_sid (json : Jsont.json) : Clock.timestamp option = 221 match json with 222 - | Jsont.Number (time, _) -> Some { sid = patch_sid; time = Float.to_int time } 223 - | Jsont.Array ([ Jsont.Number (sid, _); Jsont.Number (time, _) ], _) -> 224 Some { sid = Float.to_int sid; time = Float.to_int time } 225 | _ -> None 226 227 - (** Decode a timespan. Can be: 228 - - [time, span] (same session) 229 - - [[sid, time], span] (different session, nested) 230 - - [sid, time, span] (different session, flat) *) 231 - let decode_timespan ~patch_sid (json : Jsont.json) : Clock.timespan option = 232 match json with 233 - | Jsont.Array ([ Jsont.Number (time, _); Jsont.Number (span, _) ], _) -> 234 Some 235 { sid = patch_sid; time = Float.to_int time; span = Float.to_int span } 236 - | Jsont.Array 237 - ( [ 238 - Jsont.Array ([ Jsont.Number (sid, _); Jsont.Number (time, _) ], _); 239 - Jsont.Number (span, _); 240 - ], 241 - _ ) -> 242 Some 243 { 244 sid = Float.to_int sid; 245 time = Float.to_int time; 246 span = Float.to_int span; 247 } 248 - | Jsont.Array 249 - ( [ Jsont.Number (sid, _); Jsont.Number (time, _); Jsont.Number (span, _) ], 250 - _ ) -> 251 - (* Flat format: [sid, time, span] *) 252 Some 253 { 254 sid = Float.to_int sid; 255 time = Float.to_int time; 256 span = Float.to_int span; 257 } 258 | _ -> None 259 260 - (** Decode a Value.t from compact JSON *) 261 - let decode_con_value (json : Jsont.json) : Value.t = 262 match json with 263 - | Jsont.Null _ -> Value.Null 264 - | Jsont.Bool (b, _) -> Value.Bool b 265 - | Jsont.Number (f, _) -> 266 if Float.is_integer f then Value.Int (Float.to_int f) else Value.Float f 267 - | Jsont.String (s, _) -> Value.String s 268 | _ -> Value.Null 269 270 - (** {1 Operation Decoding} *) 271 - 272 - (** Get an element from a JSON array at index *) 273 let get_arr_elem arr idx = 274 if idx < List.length arr then Some (List.nth arr idx) else None 275 276 - (** Decode an operation from compact format *) 277 - let decode_op ~patch_sid (json : Jsont.json) : (Op.op_data, string) result = 278 match json with 279 - | Jsont.Array (elems, _) -> ( 280 match elems with 281 | [] -> Error "empty operation array" 282 - | Jsont.Number (opcode_f, _) :: args -> ( 283 let opcode = Float.to_int opcode_f in 284 match opcode with 285 | 0 -> ( 286 - (* new_con - value can be missing (undefined) or present *) 287 match args with 288 | [] -> Ok (Op.Op_new_con { con_value = Value.Undefined }) 289 | [ value_json ] -> ··· 296 | 5 -> Ok Op.Op_new_bin 297 | 6 -> Ok Op.Op_new_arr 298 | 9 -> ( 299 - (* ins_val *) 300 match args with 301 | [ obj_json; value_json ] -> ( 302 match ··· 310 | _ -> Error "ins_val: invalid timestamp") 311 | _ -> Error "ins_val: expected obj, value") 312 | 10 -> ( 313 - (* ins_obj *) 314 match args with 315 - | [ obj_json; Jsont.Array (entries, _) ] -> ( 316 match decode_ts ~patch_sid obj_json with 317 | Some obj -> 318 let decode_entry json = 319 match json with 320 - | Jsont.Array ([ Jsont.String (key, _); ts_json ], _) 321 - -> ( 322 match decode_ts ~patch_sid ts_json with 323 | Some ts -> Some (key, ts) 324 | None -> None) ··· 333 | None -> Error "ins_obj: invalid obj timestamp") 334 | _ -> Error "ins_obj: expected obj, entries") 335 | 11 -> ( 336 - (* ins_vec *) 337 match args with 338 - | [ obj_json; Jsont.Number (idx_f, _); value_json ] -> ( 339 match 340 ( decode_ts ~patch_sid obj_json, 341 decode_ts ~patch_sid value_json ) ··· 346 { 347 ins_vec_obj = obj; 348 ins_vec_idx = Float.to_int idx_f; 349 ins_vec_value = value; 350 }) 351 | _ -> Error "ins_vec: invalid timestamp") 352 | _ -> Error "ins_vec: expected obj, idx, value") 353 | 12 -> ( 354 - (* ins_str *) 355 match args with 356 - | [ obj_json; after_json; Jsont.String (value, _) ] -> ( 357 match 358 ( decode_ts ~patch_sid obj_json, 359 decode_ts ~patch_sid after_json ) ··· 369 | _ -> Error "ins_str: invalid timestamp") 370 | _ -> Error "ins_str: expected obj, after, value") 371 | 13 -> ( 372 - (* ins_bin *) 373 match args with 374 - | [ obj_json; after_json; Jsont.String (b64_value, _) ] -> ( 375 match 376 ( decode_ts ~patch_sid obj_json, 377 decode_ts ~patch_sid after_json ) ··· 390 | _ -> Error "ins_bin: invalid timestamp") 391 | _ -> Error "ins_bin: expected obj, after, value") 392 | 14 -> ( 393 - (* ins_arr - value is an array of timestamps, we take the first one *) 394 match args with 395 - | [ obj_json; after_json; Jsont.Array (values_json, _) ] -> ( 396 match 397 ( decode_ts ~patch_sid obj_json, 398 decode_ts ~patch_sid after_json ) 399 with 400 | Some obj, Some after -> ( 401 - (* Decode array of value timestamps *) 402 match values_json with 403 | [ first_value ] -> ( 404 match decode_ts ~patch_sid first_value with ··· 412 }) 413 | None -> Error "ins_arr: invalid value timestamp") 414 | _ -> ( 415 - (* Multiple values - for now just take first if available *) 416 let decoded_values = 417 List.filter_map (decode_ts ~patch_sid) values_json 418 in ··· 428 | [] -> Error "ins_arr: no valid value timestamps")) 429 | _ -> Error "ins_arr: invalid obj/after timestamp") 430 | [ obj_json; after_json; value_json ] -> ( 431 - (* Fallback: value might be a single timestamp *) 432 match 433 ( decode_ts ~patch_sid obj_json, 434 decode_ts ~patch_sid after_json, ··· 445 | _ -> Error "ins_arr: invalid timestamp") 446 | _ -> Error "ins_arr: expected obj, after, value") 447 | 15 -> ( 448 - (* upd_arr *) 449 match args with 450 | [ obj_json; pos_json; value_json ] -> ( 451 match ··· 464 | _ -> Error "upd_arr: invalid timestamp") 465 | _ -> Error "upd_arr: expected obj, pos, value") 466 | 16 -> ( 467 - (* del *) 468 match args with 469 - | [ obj_json; Jsont.Array (spans_json, _) ] -> ( 470 match decode_ts ~patch_sid obj_json with 471 | Some obj -> 472 let decoded = ··· 478 | None -> Error "del: invalid obj timestamp") 479 | _ -> Error "del: expected obj, spans") 480 | 17 -> ( 481 - (* nop *) 482 match args with 483 | [] -> Ok (Op.Op_nop { nop_len = 1 }) 484 - | [ Jsont.Number (len, _) ] -> 485 - Ok (Op.Op_nop { nop_len = Float.to_int len }) 486 | _ -> Error "nop: invalid format") 487 | _ -> Error (Printf.sprintf "unknown compact opcode: %d" opcode)) 488 | _ -> Error "operation must start with opcode number") 489 | _ -> Error "operation must be an array" 490 491 - (** {1 Patch Decoding} *) 492 - 493 - (** Decode a patch from compact JSON *) 494 - let decode_patch_json (json : Jsont.json) : (Patch.t, string) result = 495 match json with 496 - | Jsont.Array (elems, _) -> ( 497 match elems with 498 | [] -> Error "empty patch array" 499 | id_json :: ops_json -> ( 500 - (* Decode ID: [[sid, time]] *) 501 match id_json with 502 - | Jsont.Array 503 - ( [ 504 - Jsont.Array 505 - ([ Jsont.Number (sid, _); Jsont.Number (time, _) ], _); 506 - ], 507 - _ ) -> ( 508 let id : Clock.timestamp = 509 { sid = Float.to_int sid; time = Float.to_int time } 510 in 511 let patch_sid = id.sid in 512 - (* Decode operations *) 513 let rec decode_ops acc = function 514 | [] -> Ok (List.rev acc) 515 | op_json :: rest -> ( ··· 523 | _ -> Error "invalid patch ID format")) 524 | _ -> Error "patch must be an array" 525 526 - (** Decode a patch from a compact JSON string *) 527 let decode (s : string) : (Patch.t, string) result = 528 - match Jsont_bytesrw.decode_string Jsont.json s with 529 | Ok json -> decode_patch_json json 530 | Error e -> Error (Printf.sprintf "JSON parse error: %s" e) 531 532 - (** {1 Batch Encoding/Decoding} *) 533 534 - (** Encode a batch of patches to compact JSON *) 535 - let encode_batch_json (batch : Patch.batch) : Jsont.json = 536 - Jsont.Array (List.map encode_patch_json batch, meta) 537 - 538 - (** Encode a batch to a compact JSON string *) 539 let encode_batch (batch : Patch.batch) : string = 540 let json = encode_batch_json batch in 541 - Format.asprintf "%a" Jsont.pp_json json 542 543 - (** Decode a batch from compact JSON *) 544 - let decode_batch_json (json : Jsont.json) : (Patch.batch, string) result = 545 match json with 546 - | Jsont.Array (patches_json, _) -> 547 let rec decode_patches acc = function 548 | [] -> Ok (List.rev acc) 549 | patch_json :: rest -> ( ··· 554 decode_patches [] patches_json 555 | _ -> Error "expected array of patches" 556 557 - (** Decode a batch from a compact JSON string *) 558 let decode_batch (s : string) : (Patch.batch, string) result = 559 - match Jsont_bytesrw.decode_string Jsont.json s with 560 | Ok json -> decode_batch_json json 561 | Error e -> Error (Printf.sprintf "JSON parse error: %s" e)
··· 26 - 16: del 27 - 17: nop *) 28 29 + module J = Simdjsont.Json 30 31 let compact_opcode_of_op = function 32 | Op.Op_new_con _ -> 0 33 | Op.Op_new_val -> 1 ··· 46 | Op.Op_del _ -> 16 47 | Op.Op_nop _ -> 17 48 49 + let encode_ts ~patch_sid (ts : Clock.timestamp) : J.t = 50 + if ts.sid = patch_sid then J.Float (Float.of_int ts.time) 51 + else J.Array [ J.Float (Float.of_int ts.sid); J.Float (Float.of_int ts.time) ] 52 53 + let encode_timespan ~patch_sid (ts : Clock.timespan) : J.t = 54 if ts.sid = patch_sid then 55 + J.Array [ J.Float (Float.of_int ts.time); J.Float (Float.of_int ts.span) ] 56 else 57 + J.Array 58 + [ 59 + J.Array 60 + [ J.Float (Float.of_int ts.sid); J.Float (Float.of_int ts.time) ]; 61 + J.Float (Float.of_int ts.span); 62 + ] 63 64 + let encode_con_value (v : Value.t) : J.t = 65 match v with 66 + | Value.Null -> J.Null 67 + | Value.Bool b -> J.Bool b 68 + | Value.Int n -> J.Float (Float.of_int n) 69 + | Value.Float f -> J.Float f 70 + | Value.String s -> J.String s 71 + | _ -> J.Null 72 73 + let encode_op ~patch_sid (op : Op.op_data) : J.t = 74 + let opcode = J.Float (Float.of_int (compact_opcode_of_op op)) in 75 match op with 76 | Op.Op_new_con { con_value } -> 77 + J.Array [ opcode; encode_con_value con_value ] 78 | Op.Op_new_val | Op.Op_new_obj | Op.Op_new_vec | Op.Op_new_str 79 | Op.Op_new_bin | Op.Op_new_arr -> 80 + J.Array [ opcode ] 81 | Op.Op_ins_val { ins_val_obj; ins_val_value } -> 82 + J.Array 83 + [ 84 + opcode; 85 + encode_ts ~patch_sid ins_val_obj; 86 + encode_ts ~patch_sid ins_val_value; 87 + ] 88 | Op.Op_ins_obj { ins_obj_obj; ins_obj_value } -> 89 let entries = 90 List.map 91 + (fun (key, ts) -> J.Array [ J.String key; encode_ts ~patch_sid ts ]) 92 ins_obj_value 93 in 94 + J.Array [ opcode; encode_ts ~patch_sid ins_obj_obj; J.Array entries ] 95 | Op.Op_ins_vec { ins_vec_obj; ins_vec_idx; ins_vec_value } -> 96 + J.Array 97 + [ 98 + opcode; 99 + encode_ts ~patch_sid ins_vec_obj; 100 + J.Float (Float.of_int ins_vec_idx); 101 + encode_ts ~patch_sid ins_vec_value; 102 + ] 103 | Op.Op_ins_str { ins_str_obj; ins_str_after; ins_str_value } -> 104 + J.Array 105 + [ 106 + opcode; 107 + encode_ts ~patch_sid ins_str_obj; 108 + encode_ts ~patch_sid ins_str_after; 109 + J.String ins_str_value; 110 + ] 111 | Op.Op_ins_bin { ins_bin_obj; ins_bin_after; ins_bin_value } -> 112 + J.Array 113 + [ 114 + opcode; 115 + encode_ts ~patch_sid ins_bin_obj; 116 + encode_ts ~patch_sid ins_bin_after; 117 + J.String (Base64.encode_string (Bytes.to_string ins_bin_value)); 118 + ] 119 | Op.Op_ins_arr { ins_arr_obj; ins_arr_after; ins_arr_value } -> 120 + J.Array 121 + [ 122 + opcode; 123 + encode_ts ~patch_sid ins_arr_obj; 124 + encode_ts ~patch_sid ins_arr_after; 125 + encode_ts ~patch_sid ins_arr_value; 126 + ] 127 | Op.Op_upd_arr { upd_arr_obj; upd_arr_pos; upd_arr_value } -> 128 + J.Array 129 + [ 130 + opcode; 131 + encode_ts ~patch_sid upd_arr_obj; 132 + encode_ts ~patch_sid upd_arr_pos; 133 + encode_ts ~patch_sid upd_arr_value; 134 + ] 135 | Op.Op_del { del_obj; del_what } -> 136 let spans = List.map (encode_timespan ~patch_sid) del_what in 137 + J.Array [ opcode; encode_ts ~patch_sid del_obj; J.Array spans ] 138 | Op.Op_nop { nop_len } -> 139 + if nop_len = 1 then J.Array [ opcode ] 140 + else J.Array [ opcode; J.Float (Float.of_int nop_len) ] 141 142 + let encode_patch_json (patch : Patch.t) : J.t = 143 let patch_sid = patch.id.sid in 144 let id_json = 145 + J.Array 146 + [ 147 + J.Array 148 + [ 149 + J.Float (Float.of_int patch.id.sid); 150 + J.Float (Float.of_int patch.id.time); 151 + ]; 152 + ] 153 in 154 let ops_json = List.map (encode_op ~patch_sid) patch.ops in 155 + J.Array (id_json :: ops_json) 156 157 let encode (patch : Patch.t) : string = 158 let json = encode_patch_json patch in 159 + J.to_string json 160 161 let encode_pretty (patch : Patch.t) : string = 162 let json = encode_patch_json patch in 163 + J.to_string json 164 165 + let decode_ts ~patch_sid (json : J.t) : Clock.timestamp option = 166 match json with 167 + | J.Float time -> Some { sid = patch_sid; time = Float.to_int time } 168 + | J.Int time -> Some { sid = patch_sid; time = Int64.to_int time } 169 + | J.Array [ J.Float sid; J.Float time ] -> 170 Some { sid = Float.to_int sid; time = Float.to_int time } 171 + | J.Array [ J.Int sid; J.Int time ] -> 172 + Some { sid = Int64.to_int sid; time = Int64.to_int time } 173 | _ -> None 174 175 + let decode_timespan ~patch_sid (json : J.t) : Clock.timespan option = 176 match json with 177 + | J.Array [ J.Float time; J.Float span ] -> 178 Some 179 { sid = patch_sid; time = Float.to_int time; span = Float.to_int span } 180 + | J.Array [ J.Int time; J.Int span ] -> 181 + Some 182 + { sid = patch_sid; time = Int64.to_int time; span = Int64.to_int span } 183 + | J.Array [ J.Array [ J.Float sid; J.Float time ]; J.Float span ] -> 184 Some 185 { 186 sid = Float.to_int sid; 187 time = Float.to_int time; 188 span = Float.to_int span; 189 } 190 + | J.Array [ J.Array [ J.Int sid; J.Int time ]; J.Int span ] -> 191 + Some 192 + { 193 + sid = Int64.to_int sid; 194 + time = Int64.to_int time; 195 + span = Int64.to_int span; 196 + } 197 + | J.Array [ J.Float sid; J.Float time; J.Float span ] -> 198 Some 199 { 200 sid = Float.to_int sid; 201 time = Float.to_int time; 202 span = Float.to_int span; 203 } 204 + | J.Array [ J.Int sid; J.Int time; J.Int span ] -> 205 + Some 206 + { 207 + sid = Int64.to_int sid; 208 + time = Int64.to_int time; 209 + span = Int64.to_int span; 210 + } 211 | _ -> None 212 213 + let decode_con_value (json : J.t) : Value.t = 214 match json with 215 + | J.Null -> Value.Null 216 + | J.Bool b -> Value.Bool b 217 + | J.Float f -> 218 if Float.is_integer f then Value.Int (Float.to_int f) else Value.Float f 219 + | J.Int i -> Value.Int (Int64.to_int i) 220 + | J.String s -> Value.String s 221 | _ -> Value.Null 222 223 let get_arr_elem arr idx = 224 if idx < List.length arr then Some (List.nth arr idx) else None 225 226 + let _ = get_arr_elem 227 + 228 + let decode_op ~patch_sid (json : J.t) : (Op.op_data, string) result = 229 match json with 230 + | J.Array elems -> ( 231 match elems with 232 | [] -> Error "empty operation array" 233 + | J.Float opcode_f :: args -> ( 234 let opcode = Float.to_int opcode_f in 235 match opcode with 236 | 0 -> ( 237 + match args with 238 + | [] -> Ok (Op.Op_new_con { con_value = Value.Undefined }) 239 + | [ value_json ] -> 240 + Ok (Op.Op_new_con { con_value = decode_con_value value_json }) 241 + | _ -> Error "new_con: unexpected arguments") 242 + | 1 -> Ok Op.Op_new_val 243 + | 2 -> Ok Op.Op_new_obj 244 + | 3 -> Ok Op.Op_new_vec 245 + | 4 -> Ok Op.Op_new_str 246 + | 5 -> Ok Op.Op_new_bin 247 + | 6 -> Ok Op.Op_new_arr 248 + | 9 -> ( 249 + match args with 250 + | [ obj_json; value_json ] -> ( 251 + match 252 + ( decode_ts ~patch_sid obj_json, 253 + decode_ts ~patch_sid value_json ) 254 + with 255 + | Some obj, Some value -> 256 + Ok 257 + (Op.Op_ins_val 258 + { ins_val_obj = obj; ins_val_value = value }) 259 + | _ -> Error "ins_val: invalid timestamp") 260 + | _ -> Error "ins_val: expected obj, value") 261 + | 10 -> ( 262 + match args with 263 + | [ obj_json; J.Array entries ] -> ( 264 + match decode_ts ~patch_sid obj_json with 265 + | Some obj -> 266 + let decode_entry json = 267 + match json with 268 + | J.Array [ J.String key; ts_json ] -> ( 269 + match decode_ts ~patch_sid ts_json with 270 + | Some ts -> Some (key, ts) 271 + | None -> None) 272 + | _ -> None 273 + in 274 + let decoded = List.filter_map decode_entry entries in 275 + if List.length decoded = List.length entries then 276 + Ok 277 + (Op.Op_ins_obj 278 + { ins_obj_obj = obj; ins_obj_value = decoded }) 279 + else Error "ins_obj: invalid entry format" 280 + | None -> Error "ins_obj: invalid obj timestamp") 281 + | _ -> Error "ins_obj: expected obj, entries") 282 + | 11 -> ( 283 + match args with 284 + | [ obj_json; J.Float idx_f; value_json ] -> ( 285 + match 286 + ( decode_ts ~patch_sid obj_json, 287 + decode_ts ~patch_sid value_json ) 288 + with 289 + | Some obj, Some value -> 290 + Ok 291 + (Op.Op_ins_vec 292 + { 293 + ins_vec_obj = obj; 294 + ins_vec_idx = Float.to_int idx_f; 295 + ins_vec_value = value; 296 + }) 297 + | _ -> Error "ins_vec: invalid timestamp") 298 + | [ obj_json; J.Int idx_i; value_json ] -> ( 299 + match 300 + ( decode_ts ~patch_sid obj_json, 301 + decode_ts ~patch_sid value_json ) 302 + with 303 + | Some obj, Some value -> 304 + Ok 305 + (Op.Op_ins_vec 306 + { 307 + ins_vec_obj = obj; 308 + ins_vec_idx = Int64.to_int idx_i; 309 + ins_vec_value = value; 310 + }) 311 + | _ -> Error "ins_vec: invalid timestamp") 312 + | _ -> Error "ins_vec: expected obj, idx, value") 313 + | 12 -> ( 314 + match args with 315 + | [ obj_json; after_json; J.String value ] -> ( 316 + match 317 + ( decode_ts ~patch_sid obj_json, 318 + decode_ts ~patch_sid after_json ) 319 + with 320 + | Some obj, Some after -> 321 + Ok 322 + (Op.Op_ins_str 323 + { 324 + ins_str_obj = obj; 325 + ins_str_after = after; 326 + ins_str_value = value; 327 + }) 328 + | _ -> Error "ins_str: invalid timestamp") 329 + | _ -> Error "ins_str: expected obj, after, value") 330 + | 13 -> ( 331 + match args with 332 + | [ obj_json; after_json; J.String b64_value ] -> ( 333 + match 334 + ( decode_ts ~patch_sid obj_json, 335 + decode_ts ~patch_sid after_json ) 336 + with 337 + | Some obj, Some after -> ( 338 + match Base64.decode b64_value with 339 + | Ok decoded -> 340 + Ok 341 + (Op.Op_ins_bin 342 + { 343 + ins_bin_obj = obj; 344 + ins_bin_after = after; 345 + ins_bin_value = Bytes.of_string decoded; 346 + }) 347 + | Error _ -> Error "ins_bin: invalid base64") 348 + | _ -> Error "ins_bin: invalid timestamp") 349 + | _ -> Error "ins_bin: expected obj, after, value") 350 + | 14 -> ( 351 + match args with 352 + | [ obj_json; after_json; J.Array values_json ] -> ( 353 + match 354 + ( decode_ts ~patch_sid obj_json, 355 + decode_ts ~patch_sid after_json ) 356 + with 357 + | Some obj, Some after -> ( 358 + match values_json with 359 + | [ first_value ] -> ( 360 + match decode_ts ~patch_sid first_value with 361 + | Some value -> 362 + Ok 363 + (Op.Op_ins_arr 364 + { 365 + ins_arr_obj = obj; 366 + ins_arr_after = after; 367 + ins_arr_value = value; 368 + }) 369 + | None -> Error "ins_arr: invalid value timestamp") 370 + | _ -> ( 371 + let decoded_values = 372 + List.filter_map (decode_ts ~patch_sid) values_json 373 + in 374 + match decoded_values with 375 + | value :: _ -> 376 + Ok 377 + (Op.Op_ins_arr 378 + { 379 + ins_arr_obj = obj; 380 + ins_arr_after = after; 381 + ins_arr_value = value; 382 + }) 383 + | [] -> Error "ins_arr: no valid value timestamps")) 384 + | _ -> Error "ins_arr: invalid obj/after timestamp") 385 + | [ obj_json; after_json; value_json ] -> ( 386 + match 387 + ( decode_ts ~patch_sid obj_json, 388 + decode_ts ~patch_sid after_json, 389 + decode_ts ~patch_sid value_json ) 390 + with 391 + | Some obj, Some after, Some value -> 392 + Ok 393 + (Op.Op_ins_arr 394 + { 395 + ins_arr_obj = obj; 396 + ins_arr_after = after; 397 + ins_arr_value = value; 398 + }) 399 + | _ -> Error "ins_arr: invalid timestamp") 400 + | _ -> Error "ins_arr: expected obj, after, value") 401 + | 15 -> ( 402 + match args with 403 + | [ obj_json; pos_json; value_json ] -> ( 404 + match 405 + ( decode_ts ~patch_sid obj_json, 406 + decode_ts ~patch_sid pos_json, 407 + decode_ts ~patch_sid value_json ) 408 + with 409 + | Some obj, Some pos, Some value -> 410 + Ok 411 + (Op.Op_upd_arr 412 + { 413 + upd_arr_obj = obj; 414 + upd_arr_pos = pos; 415 + upd_arr_value = value; 416 + }) 417 + | _ -> Error "upd_arr: invalid timestamp") 418 + | _ -> Error "upd_arr: expected obj, pos, value") 419 + | 16 -> ( 420 + match args with 421 + | [ obj_json; J.Array spans_json ] -> ( 422 + match decode_ts ~patch_sid obj_json with 423 + | Some obj -> 424 + let decoded = 425 + List.filter_map (decode_timespan ~patch_sid) spans_json 426 + in 427 + if List.length decoded = List.length spans_json then 428 + Ok (Op.Op_del { del_obj = obj; del_what = decoded }) 429 + else Error "del: invalid timespan format" 430 + | None -> Error "del: invalid obj timestamp") 431 + | _ -> Error "del: expected obj, spans") 432 + | 17 -> ( 433 + match args with 434 + | [] -> Ok (Op.Op_nop { nop_len = 1 }) 435 + | [ J.Float len ] -> Ok (Op.Op_nop { nop_len = Float.to_int len }) 436 + | [ J.Int len ] -> Ok (Op.Op_nop { nop_len = Int64.to_int len }) 437 + | _ -> Error "nop: invalid format") 438 + | _ -> Error (Printf.sprintf "unknown compact opcode: %d" opcode)) 439 + | J.Int opcode_i :: args -> ( 440 + let opcode = Int64.to_int opcode_i in 441 + match opcode with 442 + | 0 -> ( 443 match args with 444 | [] -> Ok (Op.Op_new_con { con_value = Value.Undefined }) 445 | [ value_json ] -> ··· 452 | 5 -> Ok Op.Op_new_bin 453 | 6 -> Ok Op.Op_new_arr 454 | 9 -> ( 455 match args with 456 | [ obj_json; value_json ] -> ( 457 match ··· 465 | _ -> Error "ins_val: invalid timestamp") 466 | _ -> Error "ins_val: expected obj, value") 467 | 10 -> ( 468 match args with 469 + | [ obj_json; J.Array entries ] -> ( 470 match decode_ts ~patch_sid obj_json with 471 | Some obj -> 472 let decode_entry json = 473 match json with 474 + | J.Array [ J.String key; ts_json ] -> ( 475 match decode_ts ~patch_sid ts_json with 476 | Some ts -> Some (key, ts) 477 | None -> None) ··· 486 | None -> Error "ins_obj: invalid obj timestamp") 487 | _ -> Error "ins_obj: expected obj, entries") 488 | 11 -> ( 489 match args with 490 + | [ obj_json; J.Float idx_f; value_json ] -> ( 491 match 492 ( decode_ts ~patch_sid obj_json, 493 decode_ts ~patch_sid value_json ) ··· 498 { 499 ins_vec_obj = obj; 500 ins_vec_idx = Float.to_int idx_f; 501 + ins_vec_value = value; 502 + }) 503 + | _ -> Error "ins_vec: invalid timestamp") 504 + | [ obj_json; J.Int idx_i; value_json ] -> ( 505 + match 506 + ( decode_ts ~patch_sid obj_json, 507 + decode_ts ~patch_sid value_json ) 508 + with 509 + | Some obj, Some value -> 510 + Ok 511 + (Op.Op_ins_vec 512 + { 513 + ins_vec_obj = obj; 514 + ins_vec_idx = Int64.to_int idx_i; 515 ins_vec_value = value; 516 }) 517 | _ -> Error "ins_vec: invalid timestamp") 518 | _ -> Error "ins_vec: expected obj, idx, value") 519 | 12 -> ( 520 match args with 521 + | [ obj_json; after_json; J.String value ] -> ( 522 match 523 ( decode_ts ~patch_sid obj_json, 524 decode_ts ~patch_sid after_json ) ··· 534 | _ -> Error "ins_str: invalid timestamp") 535 | _ -> Error "ins_str: expected obj, after, value") 536 | 13 -> ( 537 match args with 538 + | [ obj_json; after_json; J.String b64_value ] -> ( 539 match 540 ( decode_ts ~patch_sid obj_json, 541 decode_ts ~patch_sid after_json ) ··· 554 | _ -> Error "ins_bin: invalid timestamp") 555 | _ -> Error "ins_bin: expected obj, after, value") 556 | 14 -> ( 557 match args with 558 + | [ obj_json; after_json; J.Array values_json ] -> ( 559 match 560 ( decode_ts ~patch_sid obj_json, 561 decode_ts ~patch_sid after_json ) 562 with 563 | Some obj, Some after -> ( 564 match values_json with 565 | [ first_value ] -> ( 566 match decode_ts ~patch_sid first_value with ··· 574 }) 575 | None -> Error "ins_arr: invalid value timestamp") 576 | _ -> ( 577 let decoded_values = 578 List.filter_map (decode_ts ~patch_sid) values_json 579 in ··· 589 | [] -> Error "ins_arr: no valid value timestamps")) 590 | _ -> Error "ins_arr: invalid obj/after timestamp") 591 | [ obj_json; after_json; value_json ] -> ( 592 match 593 ( decode_ts ~patch_sid obj_json, 594 decode_ts ~patch_sid after_json, ··· 605 | _ -> Error "ins_arr: invalid timestamp") 606 | _ -> Error "ins_arr: expected obj, after, value") 607 | 15 -> ( 608 match args with 609 | [ obj_json; pos_json; value_json ] -> ( 610 match ··· 623 | _ -> Error "upd_arr: invalid timestamp") 624 | _ -> Error "upd_arr: expected obj, pos, value") 625 | 16 -> ( 626 match args with 627 + | [ obj_json; J.Array spans_json ] -> ( 628 match decode_ts ~patch_sid obj_json with 629 | Some obj -> 630 let decoded = ··· 636 | None -> Error "del: invalid obj timestamp") 637 | _ -> Error "del: expected obj, spans") 638 | 17 -> ( 639 match args with 640 | [] -> Ok (Op.Op_nop { nop_len = 1 }) 641 + | [ J.Float len ] -> Ok (Op.Op_nop { nop_len = Float.to_int len }) 642 + | [ J.Int len ] -> Ok (Op.Op_nop { nop_len = Int64.to_int len }) 643 | _ -> Error "nop: invalid format") 644 | _ -> Error (Printf.sprintf "unknown compact opcode: %d" opcode)) 645 | _ -> Error "operation must start with opcode number") 646 | _ -> Error "operation must be an array" 647 648 + let decode_patch_json (json : J.t) : (Patch.t, string) result = 649 match json with 650 + | J.Array elems -> ( 651 match elems with 652 | [] -> Error "empty patch array" 653 | id_json :: ops_json -> ( 654 match id_json with 655 + | J.Array [ J.Array [ J.Float sid; J.Float time ] ] -> ( 656 let id : Clock.timestamp = 657 { sid = Float.to_int sid; time = Float.to_int time } 658 in 659 let patch_sid = id.sid in 660 + let rec decode_ops acc = function 661 + | [] -> Ok (List.rev acc) 662 + | op_json :: rest -> ( 663 + match decode_op ~patch_sid op_json with 664 + | Ok op -> decode_ops (op :: acc) rest 665 + | Error e -> Error e) 666 + in 667 + match decode_ops [] ops_json with 668 + | Ok ops -> Ok (Patch.create ~id ~ops) 669 + | Error e -> Error e) 670 + | J.Array [ J.Array [ J.Int sid; J.Int time ] ] -> ( 671 + let id : Clock.timestamp = 672 + { sid = Int64.to_int sid; time = Int64.to_int time } 673 + in 674 + let patch_sid = id.sid in 675 let rec decode_ops acc = function 676 | [] -> Ok (List.rev acc) 677 | op_json :: rest -> ( ··· 685 | _ -> Error "invalid patch ID format")) 686 | _ -> Error "patch must be an array" 687 688 let decode (s : string) : (Patch.t, string) result = 689 + match Simdjsont.Decode.decode_string Simdjsont.Decode.value s with 690 | Ok json -> decode_patch_json json 691 | Error e -> Error (Printf.sprintf "JSON parse error: %s" e) 692 693 + let encode_batch_json (batch : Patch.batch) : J.t = 694 + J.Array (List.map encode_patch_json batch) 695 696 let encode_batch (batch : Patch.batch) : string = 697 let json = encode_batch_json batch in 698 + J.to_string json 699 700 + let decode_batch_json (json : J.t) : (Patch.batch, string) result = 701 match json with 702 + | J.Array patches_json -> 703 let rec decode_patches acc = function 704 | [] -> Ok (List.rev acc) 705 | patch_json :: rest -> ( ··· 710 decode_patches [] patches_json 711 | _ -> Error "expected array of patches" 712 713 let decode_batch (s : string) : (Patch.batch, string) result = 714 + match Simdjsont.Decode.decode_string Simdjsont.Decode.value s with 715 | Ok json -> decode_batch_json json 716 | Error e -> Error (Printf.sprintf "JSON parse error: %s" e)
+34 -54
lib/value_codec.ml
··· 1 - (** JSON codec for Value.t using jsont. 2 3 - This module provides encode/decode functions for Value.t to/from JSON using 4 - the jsont library. *) 5 6 - (** Convert a Value.t to Jsont.json (generic JSON AST) *) 7 - let rec to_json (v : Value.t) : Jsont.json = 8 - let meta = Jsont.Meta.none in 9 match v with 10 - | Value.Null -> Jsont.Null ((), meta) 11 - | Value.Undefined -> Jsont.Null ((), meta) (* Lossy: undefined -> null *) 12 - | Value.Bool b -> Jsont.Bool (b, meta) 13 - | Value.Int i -> Jsont.Number (Float.of_int i, meta) 14 - | Value.Float f -> 15 - if not (Float.is_finite f) then Jsont.Null ((), meta) 16 - (* Non-finite floats become null *) 17 - else Jsont.Number (f, meta) 18 - | Value.String s -> Jsont.String (s, meta) 19 | Value.Bytes b -> 20 - (* Encode bytes as hex string for now (base64 needs extra dep) *) 21 let hex = 22 let buf = Buffer.create (Bytes.length b * 2) in 23 Bytes.iter ··· 25 b; 26 Buffer.contents buf 27 in 28 - Jsont.String (hex, meta) 29 - | Value.Array items -> Jsont.Array (List.map to_json items, meta) 30 | Value.Object pairs -> 31 - let mems = List.map (fun (k, v) -> ((k, meta), to_json v)) pairs in 32 - Jsont.Object (mems, meta) 33 | Value.Timestamp_ref (sid, time) -> 34 - (* Encode as [sid, time] array per json-joy spec *) 35 - Jsont.Array 36 - ( [ 37 - Jsont.Number (Float.of_int sid, meta); 38 - Jsont.Number (Float.of_int time, meta); 39 - ], 40 - meta ) 41 42 - (** Convert Jsont.json to Value.t *) 43 - let rec of_json (j : Jsont.json) : Value.t = 44 match j with 45 - | Jsont.Null _ -> Value.Null 46 - | Jsont.Bool (b, _) -> Value.Bool b 47 - | Jsont.Number (f, _) -> 48 - (* Check if it's an integer *) 49 - if 50 - Float.is_integer f 51 - && f >= Float.of_int Int.min_int 52 - && f <= Float.of_int Int.max_int 53 - then Value.Int (Float.to_int f) 54 - else Value.Float f 55 - | Jsont.String (s, _) -> Value.String s 56 - | Jsont.Array (items, _) -> Value.Array (List.map of_json items) 57 - | Jsont.Object (mems, _) -> 58 - Value.Object (List.map (fun ((k, _), v) -> (k, of_json v)) mems) 59 - 60 - (** Encode a Value.t to a JSON string (minified) *) 61 - let encode (v : Value.t) : string = 62 - let json = to_json v in 63 - Format.asprintf "%a" Jsont.pp_json json 64 65 - (** Encode a Value.t to a JSON string (pretty-printed) *) 66 - let encode_pretty (v : Value.t) : string = 67 - let json = to_json v in 68 - Format.asprintf "%a" (Jsont.pp_json' ()) json 69 70 - (** Decode a JSON string to a Value.t *) 71 let decode (s : string) : (Value.t, string) result = 72 - match Jsont_bytesrw.decode_string Jsont.json s with 73 | Ok json -> Ok (of_json json) 74 | Error e -> Error e
··· 1 + module J = Json_compat 2 3 + type json = J.json 4 5 + let rec to_json (v : Value.t) : json = 6 match v with 7 + | Value.Null -> J.null 8 + | Value.Undefined -> J.null 9 + | Value.Bool b -> J.bool b 10 + | Value.Int i -> 11 + if i >= -9007199254740991 && i <= 9007199254740991 then 12 + J.number (Float.of_int i) 13 + else Simdjsont.Json.Int (Int64.of_int i) 14 + | Value.Float f -> if Float.is_finite f then J.number f else J.null 15 + | Value.String s -> J.string s 16 | Value.Bytes b -> 17 let hex = 18 let buf = Buffer.create (Bytes.length b * 2) in 19 Bytes.iter ··· 21 b; 22 Buffer.contents buf 23 in 24 + J.string hex 25 + | Value.Array items -> J.array (List.map to_json items) 26 | Value.Object pairs -> 27 + J.object_ (List.map (fun (k, v) -> (k, to_json v)) pairs) 28 | Value.Timestamp_ref (sid, time) -> 29 + J.array [ J.number (Float.of_int sid); J.number (Float.of_int time) ] 30 31 + let rec of_json (j : json) : Value.t = 32 match j with 33 + | Simdjsont.Json.Null -> Value.Null 34 + | Simdjsont.Json.Bool b -> Value.Bool b 35 + | Simdjsont.Json.Float f -> ( 36 + match J.float_to_int_opt f with 37 + | Some i -> Value.Int i 38 + | None -> Value.Float f) 39 + | Simdjsont.Json.Int i -> 40 + if i >= Int64.of_int Int.min_int && i <= Int64.of_int Int.max_int then 41 + Value.Int (Int64.to_int i) 42 + else Value.Float (Int64.to_float i) 43 + | Simdjsont.Json.String s -> Value.String s 44 + | Simdjsont.Json.Array items -> Value.Array (List.map of_json items) 45 + | Simdjsont.Json.Object mems -> 46 + Value.Object (List.map (fun (k, v) -> (k, of_json v)) mems) 47 48 + let encode (v : Value.t) : string = J.to_string (to_json v) 49 + let encode_pretty (v : Value.t) : string = J.to_string (to_json v) 50 51 let decode (s : string) : (Value.t, string) result = 52 + match J.decode_string s with 53 | Ok json -> Ok (of_json json) 54 | Error e -> Error e
+12 -11
test/test_crdt.ml
··· 1 (** CRDT Library Tests *) 2 3 open Crdt 4 5 (* Find the project root by looking for dune-project file *) 6 let find_project_root () = ··· 254 255 let test_codec_array () = 256 let arr = Value.array [ Value.int 1; Value.int 2; Value.int 3 ] in 257 - Alcotest.(check string) "encode array" "[1, 2, 3]" (Value_codec.encode arr); 258 match Value_codec.decode "[1,2,3]" with 259 | Ok v -> Alcotest.(check value_testable) "decode array" arr v 260 | Error e -> Alcotest.fail e ··· 1618 let json = Model_codec.Verbose.encode model in 1619 (* Verify structure *) 1620 match json with 1621 - | Jsont.Object (fields, _) -> 1622 - let has_time = List.exists (fun ((k, _), _) -> k = "time") fields in 1623 - let has_root = List.exists (fun ((k, _), _) -> k = "root") fields in 1624 Alcotest.(check bool) "has time" true has_time; 1625 Alcotest.(check bool) "has root" true has_root 1626 | _ -> Alcotest.fail "expected object" ··· 3741 let json = Model_codec_sidecar.to_json sidecar in 3742 (* Should have view and meta fields *) 3743 match json with 3744 - | Jsont.Object (fields, _) -> 3745 - let has_view = List.exists (fun ((k, _), _) -> k = "view") fields in 3746 - let has_meta = List.exists (fun ((k, _), _) -> k = "meta") fields in 3747 Alcotest.(check bool) "has view" true has_view; 3748 Alcotest.(check bool) "has meta" true has_meta 3749 | _ -> Alcotest.fail "expected object" ··· 3891 let json = Model_codec_indexed.encode model in 3892 (* Should have clock, root, and nodes fields *) 3893 match json with 3894 - | Jsont.Object (fields, _) -> 3895 - let has_clock = List.exists (fun ((k, _), _) -> k = "clock") fields in 3896 - let has_root = List.exists (fun ((k, _), _) -> k = "root") fields in 3897 - let has_nodes = List.exists (fun ((k, _), _) -> k = "nodes") fields in 3898 Alcotest.(check bool) "has clock" true has_clock; 3899 Alcotest.(check bool) "has root" true has_root; 3900 Alcotest.(check bool) "has nodes" true has_nodes
··· 1 (** CRDT Library Tests *) 2 3 open Crdt 4 + module J = Simdjsont.Json 5 6 (* Find the project root by looking for dune-project file *) 7 let find_project_root () = ··· 255 256 let test_codec_array () = 257 let arr = Value.array [ Value.int 1; Value.int 2; Value.int 3 ] in 258 + Alcotest.(check string) "encode array" "[1,2,3]" (Value_codec.encode arr); 259 match Value_codec.decode "[1,2,3]" with 260 | Ok v -> Alcotest.(check value_testable) "decode array" arr v 261 | Error e -> Alcotest.fail e ··· 1619 let json = Model_codec.Verbose.encode model in 1620 (* Verify structure *) 1621 match json with 1622 + | J.Object fields -> 1623 + let has_time = List.exists (fun (k, _) -> k = "time") fields in 1624 + let has_root = List.exists (fun (k, _) -> k = "root") fields in 1625 Alcotest.(check bool) "has time" true has_time; 1626 Alcotest.(check bool) "has root" true has_root 1627 | _ -> Alcotest.fail "expected object" ··· 3742 let json = Model_codec_sidecar.to_json sidecar in 3743 (* Should have view and meta fields *) 3744 match json with 3745 + | J.Object fields -> 3746 + let has_view = List.exists (fun (k, _) -> k = "view") fields in 3747 + let has_meta = List.exists (fun (k, _) -> k = "meta") fields in 3748 Alcotest.(check bool) "has view" true has_view; 3749 Alcotest.(check bool) "has meta" true has_meta 3750 | _ -> Alcotest.fail "expected object" ··· 3892 let json = Model_codec_indexed.encode model in 3893 (* Should have clock, root, and nodes fields *) 3894 match json with 3895 + | J.Object fields -> 3896 + let has_clock = List.exists (fun (k, _) -> k = "clock") fields in 3897 + let has_root = List.exists (fun (k, _) -> k = "root") fields in 3898 + let has_nodes = List.exists (fun (k, _) -> k = "nodes") fields in 3899 Alcotest.(check bool) "has clock" true has_clock; 3900 Alcotest.(check bool) "has root" true has_root; 3901 Alcotest.(check bool) "has nodes" true has_nodes