Persistent store with Git semantics: lazy reads, delayed writes, content-addressing
irmin: typed cursors with 'a t / 'a cursor and Map combinator
- Schema is now a GADT: 'a t with Opaque : H.block t,
Node : ... -> children t, Map, Rec
- Cursors carry the value type: 'a cursor
- get : 'a cursor -> 'a option (decoded value)
- put : 'a cursor -> 'a -> 'a cursor
- set : 'a cursor -> string -> H.block -> 'a cursor (raw block)
- get_block : _ cursor -> H.block option (raw escape hatch)
- step / up return existential: type step = Step : 'a cursor -> step
- map : dec:('b -> 'a) -> enc:('a -> 'b) -> 'b t -> 'a t
- produce / verify callbacks return step * 'b
- All callsites updated: backends, tests, bin commands, ocaml-scitt
- 11 tests pass
+403
-320
+5
-5
bin/cmd_del.ml
+5
-5
bin/cmd_del.ml
···
21
21
let name = match List.rev steps with n :: _ -> n | [] -> path in
22
22
let parent_c =
23
23
match parent_steps with
24
-
| [] -> Some c
25
-
| _ -> Common.navigate c parent_steps
24
+
| [] -> Some (S.Step c)
25
+
| _ -> Common.navigate (S.Step c) parent_steps
26
26
in
27
27
match parent_c with
28
28
| None ->
29
29
Common.error "Path %a not found" Common.styled_cyan path;
30
30
1
31
-
| Some pc ->
32
-
let c = S.remove pc name in
33
-
let new_hash = S.flush c heap in
31
+
| Some (S.Step pc) ->
32
+
let pc = S.remove pc name in
33
+
let new_hash = S.flush pc heap in
34
34
S.set_head heap ~branch new_hash;
35
35
Common.success "%a" Common.styled_faint
36
36
(Fmt.str "%a" Irmin.Hash.pp_short new_hash);
+3
-3
bin/cmd_proof.ml
+3
-3
bin/cmd_proof.ml
···
115
115
let proof, result =
116
116
S.produce heap tree root (fun c ->
117
117
let v = S.find c [ key ] in
118
-
(c, v))
118
+
(S.Step c, v))
119
119
in
120
120
let hash_str h =
121
121
let hex = Digestif.SHA256.to_hex h in
···
145
145
let proof, _ =
146
146
S.produce heap tree root (fun c ->
147
147
let v = S.find c [ key ] in
148
-
(c, v))
148
+
(S.Step c, v))
149
149
in
150
150
match
151
151
S.verify proof tree (fun c ->
152
152
let v = S.find c [ key ] in
153
-
(c, v))
153
+
(S.Step c, v))
154
154
with
155
155
| Ok v ->
156
156
(match output with
+6
-5
bin/cmd_set.ml
+6
-5
bin/cmd_set.ml
···
25
25
let name = match List.rev steps with n :: _ -> n | [] -> path in
26
26
(* Navigate to the parent path *)
27
27
let parent_c =
28
-
match parent_steps with [] -> Some c | _ -> Common.navigate c parent_steps
28
+
match parent_steps with
29
+
| [] -> Some (S.Step c)
30
+
| _ -> Common.navigate (S.Step c) parent_steps
29
31
in
30
-
let c =
32
+
let new_hash =
31
33
match parent_c with
32
-
| Some pc -> S.set pc name content
34
+
| Some (S.Step pc) -> S.flush (S.set pc name content) heap
33
35
| None ->
34
36
(* Parent path doesn't exist yet; set at the top level *)
35
-
S.set c name content
37
+
S.flush (S.set c name content) heap
36
38
in
37
-
let new_hash = S.flush c heap in
38
39
S.set_head heap ~branch new_hash;
39
40
Common.success "%a" Common.styled_faint
40
41
(Fmt.str "%a" Irmin.Hash.pp_short new_hash)
+8
-6
bin/cmd_tree.ml
+8
-6
bin/cmd_tree.ml
···
18
18
in
19
19
(* Navigate to the start path *)
20
20
let start_c =
21
-
match start with [] -> Some root_c | _ -> Common.navigate root_c start
21
+
match start with
22
+
| [] -> Some (S.Step root_c)
23
+
| _ -> Common.navigate (S.Step root_c) start
22
24
in
23
25
match start_c with
24
26
| None ->
25
27
Common.error "Path %a not found" Common.styled_cyan
26
28
(Option.value ~default:"/" path);
27
29
1
28
-
| Some c ->
29
-
let rec walk indent prefix c =
30
+
| Some s ->
31
+
let rec walk indent prefix (S.Step c) =
30
32
let entries = S.list c in
31
33
List.iter
32
34
(fun (name, kind) ->
···
45
47
Fmt.pr {|{"path":%S,"type":"dir"}@.|}
46
48
(String.concat "/" full_path));
47
49
(* Navigate into child using Git's entry -> target pattern *)
48
-
match Common.navigate c [ name ] with
49
-
| Some child_c -> walk (indent ^ " ") full_path child_c
50
+
match Common.navigate (S.Step c) [ name ] with
51
+
| Some child -> walk (indent ^ " ") full_path child
50
52
| None -> ()))
51
53
entries
52
54
in
53
-
walk "" start c;
55
+
walk "" start s;
54
56
0)
+8
-6
bin/common.ml
+8
-6
bin/common.ml
···
38
38
| Some h -> Some (S.at heap Irmin_git.tree h)
39
39
40
40
(** Navigate a Git tree, following entry → target links at each step. *)
41
-
let rec navigate c = function
42
-
| [] -> Some c
41
+
let rec navigate (S.Step c) = function
42
+
| [] -> Some (S.Step c)
43
43
| name :: rest -> (
44
44
match S.step c name with
45
45
| None -> None
46
-
| Some entry -> (
46
+
| Some (S.Step entry) -> (
47
47
match S.step entry "target" with
48
48
| None -> None
49
-
| Some target -> navigate target rest))
49
+
| Some s -> navigate s rest))
50
50
51
51
let find_content c path =
52
-
match navigate c path with None -> None | Some c -> S.get c
52
+
match navigate (S.Step c) path with
53
+
| None -> None
54
+
| Some (S.Step c) -> S.get_block c
53
55
54
56
let list_children c path =
55
-
match navigate c path with None -> [] | Some c -> S.list c
57
+
match navigate (S.Step c) path with None -> [] | Some (S.Step c) -> S.list c
+1
-1
lib/cbor/irmin_cbor.ml
+1
-1
lib/cbor/irmin_cbor.ml
+1
-1
lib/git/irmin_git.ml
+1
-1
lib/git/irmin_git.ml
+1
-1
lib/json/irmin_json.ml
+1
-1
lib/json/irmin_json.ml
+1
-1
lib/oci/irmin_oci.ml
+1
-1
lib/oci/irmin_oci.ml
+219
-125
lib/schema.ml
+219
-125
lib/schema.ml
···
17
17
H.block ->
18
18
(H.block, [ `Conflict of string ]) result
19
19
20
-
type packed = Pack : t -> packed
21
-
and rule = Rule : string * t -> rule
20
+
type packed = Pack : _ t -> packed
21
+
and rule = Rule : string * _ t -> rule
22
22
23
-
and t =
24
-
| Opaque : t
23
+
and _ t =
24
+
| Opaque : H.block t
25
25
| Node : {
26
-
dec : dec;
27
-
enc : enc;
26
+
dec : H.block -> children;
27
+
enc : children -> H.block;
28
28
merge : merge option;
29
29
rules : rule list;
30
30
}
31
-
-> t
32
-
| Rec : (unit -> t) -> t
31
+
-> children t
32
+
| Rec : (unit -> 'a t) -> 'a t
33
+
| Map : { schema : 'b t; dec : 'b -> 'a; enc : 'a -> 'b } -> 'a t
33
34
34
35
let opaque = Opaque
35
36
let ( => ) pat schema = Rule (pat, schema)
···
41
42
r := Some t;
42
43
t
43
44
45
+
let map ~dec ~enc schema = Map { schema; dec; enc }
46
+
47
+
(* Pattern matching *)
44
48
let pattern_match pat name =
45
49
pat = "*" || pat = name
46
50
|| Stdlib.String.length pat > 1
···
56
60
in
57
61
loop rules
58
62
59
-
let rec resolve_packed : packed -> packed =
60
-
fun p -> match p with Pack (Rec f) -> resolve_packed (Pack (f ())) | _ -> p
63
+
(* GADT walkers *)
61
64
62
65
type node_ops = {
63
-
dec : dec;
64
-
enc : enc;
66
+
nav : H.block -> children;
67
+
of_nav : children -> H.block;
65
68
merge : merge option;
66
69
rules : rule list;
67
70
}
68
71
69
-
let get_node : packed -> node_ops option = function
70
-
| Pack (Node { dec; enc; merge; rules }) -> Some { dec; enc; merge; rules }
71
-
| _ -> None
72
+
let rec get_node_ops : type a. a t -> node_ops option = function
73
+
| Opaque -> None
74
+
| Node { dec; enc; merge; rules } ->
75
+
Some { nav = dec; of_nav = enc; merge; rules }
76
+
| Rec f -> get_node_ops (f ())
77
+
| Map { schema; _ } -> get_node_ops schema
78
+
79
+
let get_node_packed (Pack s) = get_node_ops s
80
+
81
+
let rec decode : type a. a t -> H.block -> a = function
82
+
| Opaque -> Fun.id
83
+
| Node { dec; _ } -> dec
84
+
| Rec f -> decode (f ())
85
+
| Map { schema; dec; _ } -> fun block -> dec (decode schema block)
86
+
87
+
let rec encode : type a. a t -> a -> H.block = function
88
+
| Opaque -> Fun.id
89
+
| Node { enc; _ } -> enc
90
+
| Rec f -> encode (f ())
91
+
| Map { schema; enc; _ } -> fun a -> encode schema (enc a)
92
+
93
+
(* ===== Children cache ===== *)
72
94
73
95
type overlay = (string * [ `Set of H.block | `Remove ]) list
74
96
75
-
type frame = {
76
-
source : [ `Block of H.hash | `Inline of H.block ];
77
-
schema : packed;
78
-
step_name : string;
79
-
overlay : overlay;
80
-
}
97
+
type any_frame =
98
+
| Frame : {
99
+
source : [ `Block of H.hash | `Inline of H.block ];
100
+
schema : 'a t;
101
+
step_name : string;
102
+
overlay : overlay;
103
+
}
104
+
-> any_frame
81
105
82
106
type cache =
83
107
| By_name of (string, child) Hashtbl.t * string list
84
108
| By_index of child array
85
109
86
-
type cursor = {
110
+
type 'a cursor = {
87
111
heap : H.hash -> H.block option;
88
-
schema : packed;
112
+
schema : 'a t;
89
113
source : [ `Block of H.hash | `Inline of H.block ];
90
114
overlay : overlay;
91
-
parents : frame list;
115
+
parents : any_frame list;
92
116
mutable cached_children : cache option;
93
117
}
118
+
119
+
type step = Step : 'a cursor -> step
94
120
95
121
let at (heap : (H.hash, H.block, _) Heap.t) schema (h : H.hash) =
96
122
{
97
123
heap = Heap.find heap;
98
-
schema = Pack schema;
124
+
schema;
99
125
source = `Block h;
100
126
overlay = [];
101
127
parents = [];
···
103
129
}
104
130
105
131
let empty (heap : (H.hash, H.block, _) Heap.t) schema =
106
-
let resolved = resolve_packed (Pack schema) in
107
132
let empty_block =
108
-
match get_node resolved with
109
-
| Some ops -> ops.enc (Named [])
133
+
match get_node_ops schema with
134
+
| Some ops -> ops.of_nav (Named [])
110
135
| None -> failwith "Schema.empty: schema has no enc"
111
136
in
112
137
{
113
138
heap = Heap.find heap;
114
-
schema = Pack schema;
139
+
schema;
115
140
source = `Inline empty_block;
116
141
overlay = [];
117
142
parents = [];
···
172
197
let base = List.filter (fun (n, _) -> not (Hashtbl.mem removed n)) base in
173
198
Named (base @ List.rev !added)
174
199
175
-
let effective_children c =
200
+
let effective_children (type a) (c : a cursor) =
176
201
match c.cached_children with
177
202
| Some m -> m
178
203
| None ->
···
187
212
| `Remove -> None)
188
213
c.overlay)
189
214
| Some data -> (
190
-
let resolved = resolve_packed c.schema in
191
-
match get_node resolved with
215
+
match get_node_ops c.schema with
192
216
| None -> Named []
193
217
| Some ops -> (
194
-
let base = ops.dec data in
218
+
let base = ops.nav data in
195
219
if c.overlay = [] then base
196
220
else
197
221
match base with
···
207
231
c.cached_children <- Some m;
208
232
m
209
233
210
-
let step c name =
234
+
let step (type a) (c : a cursor) name =
211
235
let m = effective_children c in
212
236
match cache_find name m with
213
237
| None -> None
214
238
| Some child_source -> (
215
-
let resolved = resolve_packed c.schema in
216
-
match get_node resolved with
239
+
match get_node_ops c.schema with
217
240
| None -> None
218
241
| Some ops -> (
219
242
match find_rule ops.rules name with
220
243
| None -> None
221
-
| Some child_schema ->
244
+
| Some (Pack child_schema) ->
222
245
let frame =
223
-
{
224
-
source = c.source;
225
-
schema = c.schema;
226
-
step_name = name;
227
-
overlay = c.overlay;
228
-
}
246
+
Frame
247
+
{
248
+
source = c.source;
249
+
schema = c.schema;
250
+
step_name = name;
251
+
overlay = c.overlay;
252
+
}
229
253
in
230
254
let source =
231
255
match child_source with
···
233
257
| `Inline v -> `Inline v
234
258
in
235
259
Some
236
-
{
237
-
heap = c.heap;
238
-
schema = child_schema;
239
-
source;
240
-
overlay = [];
241
-
parents = frame :: c.parents;
242
-
cached_children = None;
243
-
}))
260
+
(Step
261
+
{
262
+
heap = c.heap;
263
+
schema = child_schema;
264
+
source;
265
+
overlay = [];
266
+
parents = frame :: c.parents;
267
+
cached_children = None;
268
+
})))
244
269
245
-
let up c =
270
+
let up (type a) (c : a cursor) =
246
271
match c.parents with
247
272
| [] -> None
248
-
| f :: rest ->
273
+
| Frame f :: rest ->
249
274
Some
250
-
{
251
-
heap = c.heap;
252
-
schema = f.schema;
253
-
source = f.source;
254
-
overlay = f.overlay;
255
-
parents = rest;
256
-
cached_children = None;
257
-
}
275
+
(Step
276
+
{
277
+
heap = c.heap;
278
+
schema = f.schema;
279
+
source = f.source;
280
+
overlay = f.overlay;
281
+
parents = rest;
282
+
cached_children = None;
283
+
})
284
+
285
+
let get (type a) (c : a cursor) : a option =
286
+
Option.map (decode c.schema) (get_data c)
287
+
288
+
let get_block c = get_data c
289
+
290
+
let put (type a) (c : a cursor) (v : a) : a cursor =
291
+
let block = encode c.schema v in
292
+
{ c with source = `Inline block; overlay = []; cached_children = None }
258
293
259
-
let get c = get_data c
260
294
let list c = cache_list (effective_children c)
261
-
let path c = List.rev_map (fun f -> f.step_name) c.parents
295
+
let path c = List.rev_map (fun (Frame f) -> f.step_name) c.parents
262
296
let hash c = match c.source with `Block h -> Some h | `Inline _ -> None
263
297
264
-
let rec find c = function
265
-
| [] -> get c
298
+
let rec find : type a. a cursor -> string list -> H.block option =
299
+
fun c -> function
300
+
| [] -> get_data c
266
301
| name :: rest -> (
267
-
match step c name with None -> None | Some child -> find child rest)
302
+
match step c name with
303
+
| None -> None
304
+
| Some (Step child) -> find child rest)
268
305
269
306
let mem c p = Option.is_some (find c p)
307
+
308
+
(* ===== Mutation ===== *)
270
309
271
310
let set c name block =
272
311
{ c with overlay = (name, `Set block) :: c.overlay; cached_children = None }
···
274
313
let remove c name =
275
314
{ c with overlay = (name, `Remove) :: c.overlay; cached_children = None }
276
315
277
-
let flush c (heap : (H.hash, H.block, _) Heap.t) =
316
+
let flush (type a) (c : a cursor) (heap : (H.hash, H.block, _) Heap.t) =
278
317
let kids = cache_to_children (effective_children c) in
279
-
let resolved = resolve_packed c.schema in
280
-
match get_node resolved with
318
+
match get_node_ops c.schema with
281
319
| None -> (
282
320
match c.source with `Block h -> h | `Inline data -> H.hash_block data)
283
321
| Some ops ->
284
-
let block = ops.enc kids in
322
+
let block = ops.of_nav kids in
285
323
let h = H.hash_block block in
286
324
Heap.put heap h block;
287
325
h
288
326
327
+
(* ===== Refs ===== *)
328
+
289
329
let head heap ~branch = Heap.find_ref heap ("refs/heads/" ^ branch)
290
330
let set_head heap ~branch h = Heap.set_ref heap ("refs/heads/" ^ branch) h
291
331
···
300
340
301
341
let update_branch heap ~branch ~old ~new_ =
302
342
Heap.cas_ref heap ("refs/heads/" ^ branch) ~test:old ~set:(Some new_)
343
+
344
+
(* ===== Commit ===== *)
303
345
304
346
let commit_node ~dec ~enc ~tree =
305
347
Node
···
327
369
328
370
type resolution = { path : string list; value : H.block }
329
371
330
-
let merge (heap : (H.hash, H.block, _) Heap.t) schema ~ancestor ~ours ~theirs
331
-
=
372
+
(* Merge works internally on packed schemas at the block level *)
373
+
let merge (type a) (heap : (H.hash, H.block, _) Heap.t) (schema : a t)
374
+
~(ancestor : a cursor) ~(ours : a cursor) ~(theirs : a cursor) =
332
375
let conflicts = ref [] in
333
376
let add_conflict ~path ~ancestor ~ours ~theirs message =
334
377
conflicts := { path; ancestor; ours; theirs; message } :: !conflicts
335
378
in
336
-
let rec merge_hash ~path schema a_hash o_hash t_hash =
379
+
let rec merge_hash ~path (Pack schema) a_hash o_hash t_hash =
337
380
if H.hash_equal o_hash t_hash then o_hash
338
381
else if H.hash_equal a_hash o_hash then t_hash
339
382
else if H.hash_equal a_hash t_hash then o_hash
···
342
385
(Heap.find heap a_hash, Heap.find heap o_hash, Heap.find heap t_hash)
343
386
with
344
387
| Some a_block, Some o_block, Some t_block ->
345
-
merge_block ~path schema a_block o_block t_block
388
+
merge_block ~path (Pack schema) a_block o_block t_block
346
389
| _ ->
347
390
add_conflict ~path ~ancestor:None ~ours:None ~theirs:None
348
391
"missing block";
349
392
o_hash
350
-
and merge_block ~path schema a_block o_block t_block =
351
-
let resolved = resolve_packed (Pack schema) in
352
-
match get_node resolved with
393
+
and merge_block ~path packed a_block o_block t_block =
394
+
match get_node_packed packed with
353
395
| None ->
354
396
add_conflict ~path ~ancestor:(Some a_block) ~ours:(Some o_block)
355
397
~theirs:(Some t_block) "leaf conflict, no merge function";
···
371
413
Heap.put heap h o_block;
372
414
h)
373
415
| None ->
374
-
let a_kids = ops.dec a_block in
375
-
let o_kids = ops.dec o_block in
376
-
let t_kids = ops.dec t_block in
416
+
let a_kids = ops.nav a_block in
417
+
let o_kids = ops.nav o_block in
418
+
let t_kids = ops.nav t_block in
377
419
let is_empty = function
378
420
| Named [] -> true
379
421
| Indexed [||] -> true
···
385
427
let h = H.hash_block o_block in
386
428
Heap.put heap h o_block;
387
429
h)
388
-
else merge_children ~path ops schema a_kids o_kids t_kids)
389
-
and merge_children ~path ops schema a_kids o_kids t_kids =
430
+
else merge_children ~path ops packed a_kids o_kids t_kids)
431
+
and merge_children ~path ops packed a_kids o_kids t_kids =
390
432
let names_of = function
391
433
| Named l -> List.map fst l
392
434
| Indexed arr -> List.init (Array.length arr) string_of_int
···
407
449
|> List.sort String.compare
408
450
in
409
451
let child_schema name =
410
-
match find_rule ops.rules name with
411
-
| Some (Pack s) -> s
412
-
| None -> Opaque
452
+
match find_rule ops.rules name with Some p -> p | None -> Pack Opaque
413
453
in
414
454
let rec merge_names acc = function
415
455
| [] ->
416
456
let merged = Named (List.rev acc) in
417
-
let block = ops.enc merged in
457
+
let block = ops.of_nav merged in
418
458
let h = H.hash_block block in
419
459
Heap.put heap h block;
420
460
h
···
422
462
let a = find_child name a_kids in
423
463
let o = find_child name o_kids in
424
464
let t = find_child name t_kids in
425
-
let child_sch = child_schema name in
465
+
let child_p = child_schema name in
426
466
let child_path = path @ [ name ] in
427
-
let result = merge_child ~path:child_path child_sch a o t in
467
+
let result = merge_child ~path:child_path child_p a o t in
428
468
match result with
429
469
| None -> merge_names acc rest
430
470
| Some child -> merge_names ((name, child) :: acc) rest)
431
-
and merge_child ~path schema a o t =
471
+
and merge_child ~path packed a o t =
432
472
match (a, o, t) with
433
473
| _, Some oc, Some tc when oc = tc -> Some oc
434
474
| Some ac, Some oc, _ when ac = oc -> t
···
442
482
match (Heap.find heap oh, Heap.find heap th) with
443
483
| Some ob, Some tb ->
444
484
let empty_block =
445
-
match get_node (resolve_packed (Pack schema)) with
446
-
| Some ops -> ops.enc (Named [])
485
+
match get_node_packed packed with
486
+
| Some ops -> ops.of_nav (Named [])
447
487
| None -> ob
448
488
in
449
-
let h = merge_block ~path schema empty_block ob tb in
489
+
let h = merge_block ~path packed empty_block ob tb in
450
490
Some (`Link h)
451
491
| _ ->
452
492
add_conflict ~path ~ancestor:None ~ours:(Heap.find heap oh)
···
485
525
"delete/modify conflict";
486
526
Some tc
487
527
| Some (`Link ah), Some (`Link oh), Some (`Link th) ->
488
-
let h = merge_hash ~path schema ah oh th in
528
+
let h = merge_hash ~path packed ah oh th in
489
529
Some (`Link h)
490
530
| Some (`Inline ab), Some (`Inline ob), Some (`Inline tb) ->
491
-
let h = merge_block ~path schema ab ob tb in
531
+
let h = merge_block ~path packed ab ob tb in
492
532
Some (`Link h)
493
533
| Some _, Some oc, Some _ ->
494
534
add_conflict ~path ~ancestor:None ~ours:None ~theirs:None
···
497
537
in
498
538
merge_names [] all_names
499
539
in
500
-
let get_hash c =
540
+
let get_hash (type b) (c : b cursor) =
501
541
match c.source with `Block h -> h | `Inline d -> H.hash_block d
502
542
in
503
543
let merged_hash =
504
-
merge_hash ~path:[] schema (get_hash ancestor) (get_hash ours)
544
+
merge_hash ~path:[] (Pack schema) (get_hash ancestor) (get_hash ours)
505
545
(get_hash theirs)
506
546
in
507
547
(at heap schema merged_hash, List.rev !conflicts)
508
548
509
-
let resolve (heap : (H.hash, H.block, _) Heap.t) _schema cursor resolutions =
510
-
let c = ref cursor in
549
+
let resolve (type a) (heap : (H.hash, H.block, _) Heap.t) (schema : a t)
550
+
(cursor : a cursor) resolutions =
551
+
(* Apply resolutions, flush, re-at with original schema *)
552
+
let step_s (Step c) name =
553
+
match step c name with None -> None | Some s -> Some s
554
+
in
555
+
let up_s (Step c) = match up c with None -> None | Some s -> Some s in
556
+
let s = ref (Step cursor) in
511
557
List.iter
512
558
(fun (r : resolution) ->
513
559
match r.path with
···
517
563
let name = List.nth r.path (List.length r.path - 1) in
518
564
let nav =
519
565
List.fold_left
520
-
(fun acc s ->
521
-
match acc with Some c -> step c s | None -> None)
522
-
(Some !c) parent_path
566
+
(fun acc n ->
567
+
match acc with Some s -> step_s s n | None -> None)
568
+
(Some !s) parent_path
523
569
in
524
570
match nav with
525
-
| Some parent ->
526
-
let updated = set parent name r.value in
527
-
let rec go_up c =
528
-
match up c with Some c' -> go_up c' | None -> c
571
+
| Some (Step parent) ->
572
+
let updated = Step (set parent name r.value) in
573
+
let rec go_up s =
574
+
match up_s s with Some s' -> go_up s' | None -> s
529
575
in
530
-
c := go_up updated
576
+
s := go_up updated
531
577
| None -> ()))
532
578
resolutions;
533
-
!c
579
+
(* Flush and reconstruct at the original schema type *)
580
+
let (Step result) = !s in
581
+
let h = flush result heap in
582
+
at heap schema h
583
+
584
+
(* ===== Merge combinators ===== *)
534
585
535
586
let merge_lww : merge = fun ~ancestor:_ _ours theirs -> Ok theirs
536
587
let merge_ours : merge = fun ~ancestor:_ ours _theirs -> Ok ours
···
543
594
[ `Add of H.block | `Remove of H.block | `Change of H.block * H.block ];
544
595
}
545
596
546
-
let diff a b =
547
-
let hash_of c =
597
+
let diff (type a) (a : a cursor) (b : a cursor) =
598
+
let hash_of (type b) (c : b cursor) =
548
599
match hash c with
549
600
| Some h -> Some h
550
-
| None -> Option.map H.hash_block (get c)
601
+
| None -> Option.map H.hash_block (get_data c)
551
602
in
552
-
let same c1 c2 =
603
+
let same (type b c) (c1 : b cursor) (c2 : c cursor) =
553
604
match (hash_of c1, hash_of c2) with
554
605
| Some h1, Some h2 -> H.hash_equal h1 h2
555
606
| _ -> false
556
607
in
557
-
let rec go ~path a b acc =
608
+
let rec go : type b. path:string list -> b cursor -> b cursor -> _ =
609
+
fun ~path a b acc ->
558
610
if same a b then acc
559
611
else
560
612
let a_kids = list a in
561
613
let b_kids = list b in
562
614
match (a_kids, b_kids) with
563
615
| [], [] -> (
564
-
match (get a, get b) with
616
+
match (get_data a, get_data b) with
565
617
| Some va, Some vb ->
566
618
{ diff_path = path; kind = `Change (va, vb) } :: acc
567
619
| None, Some vb -> { diff_path = path; kind = `Add vb } :: acc
···
576
628
(fun acc name ->
577
629
match (step a name, step b name) with
578
630
| None, None -> acc
579
-
| None, Some bc -> collect `Add ~path:(path @ [ name ]) bc acc
580
-
| Some ac, None ->
581
-
collect `Remove ~path:(path @ [ name ]) ac acc
582
-
| Some ac, Some bc -> go ~path:(path @ [ name ]) ac bc acc)
631
+
| None, Some (Step bc) ->
632
+
collect `Add ~path:(path @ [ name ]) (Step bc) acc
633
+
| Some (Step ac), None ->
634
+
collect `Remove ~path:(path @ [ name ]) (Step ac) acc
635
+
| Some (Step ac), Some (Step bc) ->
636
+
go_any ~path:(path @ [ name ]) (Step ac) (Step bc) acc)
583
637
acc all
584
-
and collect dir ~path c acc =
638
+
and go_any ~path (Step a) (Step b) acc =
639
+
(* Both are at the same structural position but possibly different types.
640
+
Compare at block level. *)
641
+
let hash_of (type b) (c : b cursor) =
642
+
match hash c with
643
+
| Some h -> Some h
644
+
| None -> Option.map H.hash_block (get_data c)
645
+
in
646
+
let same =
647
+
match (hash_of a, hash_of b) with
648
+
| Some h1, Some h2 -> H.hash_equal h1 h2
649
+
| _ -> false
650
+
in
651
+
if same then acc
652
+
else
653
+
let a_kids = list a and b_kids = list b in
654
+
match (a_kids, b_kids) with
655
+
| [], [] -> (
656
+
match (get_data a, get_data b) with
657
+
| Some va, Some vb ->
658
+
{ diff_path = path; kind = `Change (va, vb) } :: acc
659
+
| None, Some vb -> { diff_path = path; kind = `Add vb } :: acc
660
+
| Some va, None -> { diff_path = path; kind = `Remove va } :: acc
661
+
| None, None -> acc)
662
+
| _ ->
663
+
let all =
664
+
List.sort_uniq String.compare
665
+
(List.map fst a_kids @ List.map fst b_kids)
666
+
in
667
+
List.fold_left
668
+
(fun acc name ->
669
+
match (step a name, step b name) with
670
+
| None, None -> acc
671
+
| None, Some (Step bc) ->
672
+
collect `Add ~path:(path @ [ name ]) (Step bc) acc
673
+
| Some (Step ac), None ->
674
+
collect `Remove ~path:(path @ [ name ]) (Step ac) acc
675
+
| Some (Step ac), Some (Step bc) ->
676
+
go_any ~path:(path @ [ name ]) (Step ac) (Step bc) acc)
677
+
acc all
678
+
and collect dir ~path (Step c) acc =
585
679
let kids = list c in
586
680
if kids = [] then
587
-
match get c with
681
+
match get_data c with
588
682
| Some v ->
589
683
let kind = match dir with `Add -> `Add v | `Remove -> `Remove v in
590
684
{ diff_path = path; kind } :: acc
···
593
687
List.fold_left
594
688
(fun acc (name, _) ->
595
689
match step c name with
596
-
| Some child -> collect dir ~path:(path @ [ name ]) child acc
690
+
| Some s -> collect dir ~path:(path @ [ name ]) s acc
597
691
| None -> acc)
598
692
acc kids
599
693
in
···
619
713
heap : (H.hash, H.block, unit) Heap.t;
620
714
}
621
715
622
-
let produce (heap : (H.hash, H.block, _) Heap.t) schema (root : H.hash)
623
-
(f : cursor -> cursor * 'b) : proof * 'b =
716
+
let produce (type a) (heap : (H.hash, H.block, _) Heap.t) (schema : a t)
717
+
(root : H.hash) (f : a cursor -> step * 'b) : proof * 'b =
624
718
let recording_heap, get_recorded = Heap.recording heap in
625
719
let c = at recording_heap schema root in
626
-
let result_c, result = f c in
720
+
let Step result_c, result = f c in
627
721
let after =
628
722
match result_c.source with
629
723
| `Block h -> h
···
632
726
let heap = Heap.of_list ~equal:H.hash_equal (get_recorded ()) in
633
727
({ before = root; after; heap }, result)
634
728
635
-
let verify proof schema (f : cursor -> cursor * 'b) :
729
+
let verify (type a) proof (schema : a t) (f : a cursor -> step * 'b) :
636
730
('b, [ `Proof_failure of string ]) result =
637
731
let c = at proof.heap schema proof.before in
638
-
let result_c, result = f c in
732
+
let Step result_c, result = f c in
639
733
let computed =
640
734
match result_c.source with
641
735
| `Block h -> h
+99
-118
lib/schema.mli
+99
-118
lib/schema.mli
···
1
-
(** Content-addressed DAG navigation with pluggable codecs.
1
+
(** Content-addressed DAG navigation with typed cursors.
2
2
3
-
A schema describes the structure of a content-addressed DAG and how to parse
4
-
each block. The cursor navigates lazily, writes with delayed persistence,
5
-
and produces proofs as subheaps.
3
+
A schema describes the structure of a content-addressed DAG and how to
4
+
decode each block into a typed value. The cursor navigates lazily, reads
5
+
return typed values, and writes are delayed until {!flush}.
6
6
7
7
{[
8
8
let directory = node ~dec:git_tree_dec ~enc:git_tree_enc
···
10
10
11
11
let json = fix (fun self -> json_node [ "*" => self ])
12
12
let git_entry target =
13
-
entry [ "mode" => string; "target" => target ]
13
+
entry [ "mode" => opaque; "target" => target ]
14
14
let git_tree = fix (fun self ->
15
15
directory [ "*.json" => git_entry json; "*" => git_entry self ])
16
16
17
17
let c = at heap git_tree root in
18
-
let (Any c) = step c "config.json" |> Option.get in
19
-
get c
18
+
match step c "config.json" with
19
+
| Some (Step entry) ->
20
+
match get entry with Some children -> ... | None -> ...
21
+
| None -> ...
20
22
]} *)
21
23
22
24
module Make (H : sig
···
38
40
(** Positional children: array elements. O(1) index lookup. *)
39
41
40
42
type dec = H.block -> children
41
-
(** How to decode a block into its children. *)
43
+
(** Decode a block into its children. *)
42
44
43
45
type enc = children -> H.block
44
-
(** How to encode children into a block. *)
46
+
(** Encode children into a block. *)
45
47
46
48
type merge =
47
49
ancestor:H.block ->
48
50
H.block ->
49
51
H.block ->
50
52
(H.block, [ `Conflict of string ]) result
51
-
(** [merge ~ancestor ours theirs] merges two leaf values given their common
52
-
ancestor. *)
53
+
(** Block-level 3-way merge. *)
53
54
54
-
type t
55
-
(** A schema node. *)
55
+
type 'a t
56
+
(** A schema node that decodes blocks into values of type ['a]. *)
56
57
57
58
type rule
58
-
(** A pattern–schema pair. See {!(=>)}. *)
59
+
(** A pattern-schema pair. See {!(=>)}. *)
59
60
60
-
val ( => ) : string -> t -> rule
61
+
val ( => ) : string -> _ t -> rule
61
62
(** [pattern => schema] matches children by name. ["*"] matches anything,
62
63
["*.json"] matches by suffix, exact names match exactly. First matching
63
64
rule wins. *)
64
65
65
-
val node : dec:dec -> enc:enc -> ?merge:merge -> rule list -> t
66
-
(** [node ~dec ~enc ?merge rules] is a block with named children. [merge] is
67
-
used for leaf-level 3-way merge. Interior nodes are merged structurally
68
-
(child by child). *)
66
+
val node :
67
+
dec:(H.block -> children) ->
68
+
enc:(children -> H.block) ->
69
+
?merge:merge ->
70
+
rule list ->
71
+
children t
72
+
(** [node ~dec ~enc ?merge rules] is a schema for blocks with named children.
73
+
The value type is {!children}. Use {!map} to lift to a domain type. *)
74
+
75
+
val opaque : H.block t
76
+
(** No children. The value is the raw block. *)
69
77
70
-
val fix : (t -> t) -> t
78
+
val fix : ('a t -> 'a t) -> 'a t
71
79
(** [fix f] is a recursive schema. *)
72
80
73
-
val opaque : t
74
-
(** No children. *)
81
+
val map : dec:('b -> 'a) -> enc:('a -> 'b) -> 'b t -> 'a t
82
+
(** [map ~dec ~enc schema] transforms the value type. Navigation still uses
83
+
the underlying structural schema; [dec] and [enc] wrap {!get}/{!put}. *)
84
+
85
+
(** {1:cursor Typed Cursor}
75
86
76
-
(** {1:cursor Cursor}
87
+
A cursor is a position in the DAG with a known value type. Reads are lazy:
88
+
blocks are fetched on demand. Writes are delayed until {!flush}. *)
77
89
78
-
A cursor is a position in the DAG. Reads are lazy: blocks are fetched on
79
-
demand. Writes are delayed: mutations are held in memory until {!flush}.
80
-
*)
90
+
type 'a cursor
91
+
(** A position in the DAG where values have type ['a]. *)
81
92
82
-
type cursor
83
-
(** A position in the DAG. *)
93
+
type step =
94
+
| Step : 'a cursor -> step
95
+
(** Existential wrapper returned by {!val-step} and {!up}, since the
96
+
child's type depends on which rule matched. *)
84
97
85
98
(** {2 Create} *)
86
99
87
-
val at : (H.hash, H.block, _) Heap.t -> t -> H.hash -> cursor
100
+
val at : (H.hash, H.block, _) Heap.t -> 'a t -> H.hash -> 'a cursor
88
101
(** [at heap schema root] is a cursor at [root]. *)
89
102
90
-
val empty : (H.hash, H.block, _) Heap.t -> t -> cursor
103
+
val empty : (H.hash, H.block, _) Heap.t -> 'a t -> 'a cursor
91
104
(** [empty heap schema] is a cursor at an empty node. *)
92
105
93
106
(** {2 Navigate} *)
94
107
95
-
val step : cursor -> string -> cursor option
108
+
val step : _ cursor -> string -> step option
96
109
(** [step c name] moves to child [name]. *)
97
110
98
-
val up : cursor -> cursor option
111
+
val up : _ cursor -> step option
99
112
(** [up c] moves to the parent. [None] at root. *)
100
113
101
114
(** {2 Read} *)
102
115
103
-
val get : cursor -> H.block option
104
-
(** [get c] reads the block at this position. *)
116
+
val get : 'a cursor -> 'a option
117
+
(** [get c] decodes and returns the value at this position. *)
105
118
106
-
val list : cursor -> (string * [ `Node | `Leaf ]) list
119
+
val get_block : _ cursor -> H.block option
120
+
(** [get_block c] returns the raw block, bypassing the schema's decoder.
121
+
Useful when the cursor type is existentially bound (e.g., after {!step}).
122
+
*)
123
+
124
+
val list : _ cursor -> (string * [ `Node | `Leaf ]) list
107
125
(** [list c] lists children with their kind. *)
108
126
109
-
val path : cursor -> string list
127
+
val path : _ cursor -> string list
110
128
(** [path c] is the steps from root to here. *)
111
129
112
-
val hash : cursor -> H.hash option
130
+
val hash : _ cursor -> H.hash option
113
131
(** [hash c] is the block's hash, if it comes from the heap. *)
114
132
115
-
val find : cursor -> string list -> H.block option
116
-
(** [find c path] navigates [path] from [c] and reads. *)
133
+
val find : _ cursor -> string list -> H.block option
134
+
(** [find c path] navigates [path] from [c] and returns the raw block. *)
117
135
118
-
val mem : cursor -> string list -> bool
136
+
val mem : _ cursor -> string list -> bool
119
137
(** [mem c path] is [true] if [path] exists. *)
120
138
121
139
(** {2 Write} *)
122
140
123
-
val set : cursor -> string -> H.block -> cursor
124
-
(** [set c name block] sets child [name]. Returns a cursor at the same
125
-
position with the modification pending. *)
141
+
val put : 'a cursor -> 'a -> 'a cursor
142
+
(** [put c v] replaces the value at this position. *)
143
+
144
+
val set : 'a cursor -> string -> H.block -> 'a cursor
145
+
(** [set c name block] sets child [name] to a raw block. *)
126
146
127
-
val remove : cursor -> string -> cursor
147
+
val remove : 'a cursor -> string -> 'a cursor
128
148
(** [remove c name] removes child [name]. *)
129
149
130
-
val flush : cursor -> (H.hash, H.block, _) Heap.t -> H.hash
150
+
val flush : _ cursor -> (H.hash, H.block, _) Heap.t -> H.hash
131
151
(** [flush c heap] writes pending mutations to [heap] and returns the new root
132
152
hash. *)
133
153
134
-
(** {1:refs Refs}
135
-
136
-
Named mutable pointers into the heap. *)
154
+
(** {1:refs Refs} *)
137
155
138
156
val head : (H.hash, _, _) Heap.t -> branch:string -> H.hash option
139
-
(** [head heap ~branch] is the hash at the tip of [branch]. *)
140
-
141
157
val set_head : (H.hash, _, _) Heap.t -> branch:string -> H.hash -> unit
142
-
(** [set_head heap ~branch h] advances [branch] to [h]. *)
143
-
144
158
val branches : (_, _, _) Heap.t -> string list
145
-
(** [branches heap] lists all branches. *)
146
159
147
160
val update_branch :
148
161
(H.hash, _, _) Heap.t ->
···
150
163
old:H.hash option ->
151
164
new_:H.hash ->
152
165
bool
153
-
(** [update_branch heap ~branch ~old ~new_] is a compare-and-set. *)
154
166
155
-
(** {1:commit Commits}
167
+
(** {1:commit Commits} *)
156
168
157
-
A commit is a node linking a tree root to parents with metadata. Describe
158
-
it as a {!node} with parse/serialize for the commit format. *)
159
-
160
-
val commit_node : dec:dec -> enc:enc -> tree:t -> t
161
-
(** [commit_node ~dec ~enc ~tree] is a schema for commit blocks. Children:
162
-
["tree"] links to [tree], ["parent/0"], ["parent/1"], ... link to parent
163
-
commits, ["message"] and ["author"] are inline metadata. *)
164
-
165
-
(** {1:merge Merge}
166
-
167
-
Two-phase 3-way merge. Phase 1 resolves everything the schema can merge
168
-
automatically (structural merge for trees, typed merge functions for
169
-
leaves/values). Phase 2 surfaces remaining conflicts for external
170
-
resolution.
169
+
val commit_node :
170
+
dec:(H.block -> children) ->
171
+
enc:(children -> H.block) ->
172
+
tree:_ t ->
173
+
children t
171
174
172
-
Phase 1 always succeeds: it returns a merged tree plus a conflict list.
173
-
For types with total merge functions (counters, sets, LWW), the conflict
174
-
list is always empty -- eventual consistency for free. *)
175
+
(** {1:merge Merge} *)
175
176
176
177
type conflict = {
177
178
path : string list;
···
185
186
186
187
val merge :
187
188
(H.hash, H.block, _) Heap.t ->
188
-
t ->
189
-
ancestor:cursor ->
190
-
ours:cursor ->
191
-
theirs:cursor ->
192
-
cursor * conflict list
193
-
(** [merge heap schema ~ancestor ~ours ~theirs] performs a two-phase 3-way
194
-
merge. Always returns a cursor at the (partially) merged tree. Conflicts
195
-
are returned alongside the result, not instead of it. *)
189
+
'a t ->
190
+
ancestor:'a cursor ->
191
+
ours:'a cursor ->
192
+
theirs:'a cursor ->
193
+
'a cursor * conflict list
196
194
197
195
val resolve :
198
-
(H.hash, H.block, _) Heap.t -> t -> cursor -> resolution list -> cursor
199
-
(** [resolve heap schema cursor resolutions] applies conflict resolutions. *)
200
-
201
-
(** {2 Generic merge combinators}
202
-
203
-
These work at the block level (they don't inspect the value). *)
196
+
(H.hash, H.block, _) Heap.t ->
197
+
'a t ->
198
+
'a cursor ->
199
+
resolution list ->
200
+
'a cursor
204
201
205
202
val merge_lww : merge
206
-
(** Last-write-wins: picks [theirs]. Always resolves. *)
207
-
208
203
val merge_ours : merge
209
-
(** Always picks [ours]. Always resolves. *)
210
204
211
-
(** {1:diff Diff}
212
-
213
-
Structural diff between two trees, and ddiff for 4-point merge workflows
214
-
(a la Jane Street Iron). *)
205
+
(** {1:diff Diff} *)
215
206
216
207
type diff_entry = {
217
208
diff_path : string list;
···
219
210
[ `Add of H.block | `Remove of H.block | `Change of H.block * H.block ];
220
211
}
221
212
222
-
val diff : cursor -> cursor -> diff_entry list
223
-
(** [diff a b] returns the structural difference between trees [a] and [b]. *)
213
+
val diff : 'a cursor -> 'a cursor -> diff_entry list
224
214
225
215
val ddiff :
226
-
old_base:cursor ->
227
-
old_tip:cursor ->
228
-
new_base:cursor ->
229
-
new_tip:cursor ->
216
+
old_base:'a cursor ->
217
+
old_tip:'a cursor ->
218
+
new_base:'a cursor ->
219
+
new_tip:'a cursor ->
230
220
diff_entry list
231
-
(** [ddiff ~old_base ~old_tip ~new_base ~new_tip] computes the diff of two
232
-
diffs. Iron's 4-point merge for incremental review. *)
233
221
234
-
(** {1:proof Proofs}
235
-
236
-
A proof is a subheap: a {!Heap.t} containing only the blocks needed to
237
-
replay a computation. *)
222
+
(** {1:proof Proofs} *)
238
223
239
224
type proof = {
240
-
before : H.hash; (** Root hash before the computation. *)
241
-
after : H.hash; (** Root hash after the computation. *)
242
-
heap : (H.hash, H.block, unit) Heap.t; (** The subheap. *)
225
+
before : H.hash;
226
+
after : H.hash;
227
+
heap : (H.hash, H.block, unit) Heap.t;
243
228
}
244
229
245
230
val produce :
246
231
(H.hash, H.block, _) Heap.t ->
247
-
t ->
232
+
'a t ->
248
233
H.hash ->
249
-
(cursor -> cursor * 'a) ->
250
-
proof * 'a
251
-
(** [produce heap schema root f] runs [f] on [heap] and returns the subheap
252
-
that [f] read, together with [f]'s result. *)
234
+
('a cursor -> step * 'b) ->
235
+
proof * 'b
253
236
254
237
val verify :
255
238
proof ->
256
-
t ->
257
-
(cursor -> cursor * 'a) ->
258
-
('a, [ `Proof_failure of string ]) result
259
-
(** [verify proof schema f] replays [f] on [proof.heap]. Returns [f]'s result
260
-
if the final hash matches [proof.after]. *)
239
+
'a t ->
240
+
('a cursor -> step * 'b) ->
241
+
('b, [ `Proof_failure of string ]) result
261
242
end
+6
-6
test/bench/bench.ml
+6
-6
test/bench/bench.ml
···
34
34
List.iter
35
35
(fun (name, _) ->
36
36
match S.step c name with
37
-
| Some entry -> (
37
+
| Some (S.Step entry) -> (
38
38
match S.step entry "target" with
39
-
| Some blob -> ignore (S.get blob)
39
+
| Some (S.Step blob) -> ignore (S.get_block blob)
40
40
| None -> ())
41
41
| None -> ())
42
42
kids
···
48
48
assert (List.length kids = n);
49
49
(* Navigate to first entry *)
50
50
match S.step c (Fmt.str "key-%04d" 0) with
51
-
| Some entry -> (
51
+
| Some (S.Step entry) -> (
52
52
match S.step entry "target" with
53
-
| Some blob -> (blob, S.get blob)
54
-
| None -> (c, None))
55
-
| None -> (c, None))
53
+
| Some (S.Step blob) -> (S.Step blob, S.get_block blob)
54
+
| None -> (S.Step c, None))
55
+
| None -> (S.Step c, None))
56
56
in
57
57
()
58
58
+3
-3
test/mst_proof/mst_proof.ml
+3
-3
test/mst_proof/mst_proof.ml
···
46
46
47
47
(* Produce a proof for reading a post *)
48
48
let read_post c =
49
-
let post = S.step c "post" |> Option.get in
50
-
let v = S.step post "3k2yihx" |> Option.get in
51
-
(v, S.get v)
49
+
let (S.Step post) = S.step c "post" |> Option.get in
50
+
let (S.Step v) = S.step post "3k2yihx" |> Option.get in
51
+
(S.Step v, S.get_block v)
52
52
in
53
53
let proof, value = S.produce heap Irmin_tar.tree root read_post in
54
54
+19
-18
test/schema/test.ml
+19
-18
test/schema/test.ml
···
122
122
Alcotest.(check (list string)) "root" [ "config.json"; "main.ml" ] kids;
123
123
124
124
(* Step into config.json entry *)
125
-
let c = S.step c "config.json" |> Option.get in
125
+
let (S.Step c) = S.step c "config.json" |> Option.get in
126
126
let entry_kids = S.list c |> List.map fst |> List.sort String.compare in
127
127
Alcotest.(check (list string))
128
128
"entry fields" [ "mode"; "target" ] entry_kids;
129
129
130
130
(* Mode *)
131
-
let c_mode = S.step c "mode" |> Option.get in
132
-
Alcotest.(check (option string)) "mode" (Some "100644") (S.get c_mode);
131
+
let (S.Step c_mode) = S.step c "mode" |> Option.get in
132
+
Alcotest.(check (option string))
133
+
"mode" (Some "100644") (S.get_block c_mode);
133
134
134
135
(* Follow target link → JSON blob *)
135
-
let c_blob = S.step c "target" |> Option.get in
136
+
let (S.Step c_blob) = S.step c "target" |> Option.get in
136
137
137
138
(* JSON navigation: object keys *)
138
139
let json_kids =
···
141
142
Alcotest.(check (list string)) "json keys" [ "name"; "version" ] json_kids;
142
143
143
144
(* Step into JSON "name" *)
144
-
let c_name = S.step c_blob "name" |> Option.get in
145
+
let (S.Step c_name) = S.step c_blob "name" |> Option.get in
145
146
Alcotest.(check (option string))
146
-
"json name" (Some {|"irmin"|}) (S.get c_name);
147
+
"json name" (Some {|"irmin"|}) (S.get_block c_name);
147
148
148
149
(* Go up: name → blob → entry → tree *)
149
-
let c_up = S.up c_name |> Option.get in
150
-
let c_up = S.up c_up |> Option.get in
151
-
let c_up = S.up c_up |> Option.get in
150
+
let (S.Step c_up) = S.up c_name |> Option.get in
151
+
let (S.Step c_up) = S.up c_up |> Option.get in
152
+
let (S.Step c_up) = S.up c_up |> Option.get in
152
153
let root_kids = S.list c_up |> List.map fst |> List.sort String.compare in
153
154
Alcotest.(check (list string))
154
155
"back to root"
···
185
186
186
187
(* The computation: navigate to data.json → target → key *)
187
188
let read_key c =
188
-
let c = S.step c "data.json" |> Option.get in
189
-
let c = S.step c "target" |> Option.get in
190
-
let c = S.step c "key" |> Option.get in
191
-
(c, S.get c)
189
+
let (S.Step c) = S.step c "data.json" |> Option.get in
190
+
let (S.Step c) = S.step c "target" |> Option.get in
191
+
let (S.Step c) = S.step c "key" |> Option.get in
192
+
(S.Step c, S.get_block c)
192
193
in
193
194
194
195
(* Produce *)
···
260
261
(Option.is_none (S.step c "does_not_exist"));
261
262
262
263
(* Step to existing child, then nonexistent subchild *)
263
-
let c = S.step c "a.ml" |> Option.get in
264
+
let (S.Step c) = S.step c "a.ml" |> Option.get in
264
265
Alcotest.(check bool)
265
266
"no such field" true
266
267
(Option.is_none (S.step c "nonexistent_field")))
···
286
287
let heap = Irmin_git.heap repo in
287
288
288
289
let read c =
289
-
let c = S.step c "f.json" |> Option.get in
290
-
let c = S.step c "target" |> Option.get in
291
-
let c = S.step c "k" |> Option.get in
292
-
(c, S.get c)
290
+
let (S.Step c) = S.step c "f.json" |> Option.get in
291
+
let (S.Step c) = S.step c "target" |> Option.get in
292
+
let (S.Step c) = S.step c "k" |> Option.get in
293
+
(S.Step c, S.get_block c)
293
294
in
294
295
295
296
(* Produce a valid proof *)
+23
-21
test/tar/test.ml
+23
-21
test/tar/test.ml
···
46
46
Alcotest.(check (list string)) "root dirs" [ "README.md"; "doc"; "src" ] kids;
47
47
48
48
(* Step into src *)
49
-
let src = S.step c "src" |> Option.get in
49
+
let (S.Step src) = S.step c "src" |> Option.get in
50
50
let src_kids = S.list src |> List.map fst |> List.sort String.compare in
51
51
Alcotest.(check (list string)) "src files" [ "main.ml"; "util.ml" ] src_kids;
52
52
53
53
(* Read a file *)
54
-
let main = S.step src "main.ml" |> Option.get in
55
-
Alcotest.(check (option string)) "main.ml" (Some "let () = ()") (S.get main);
54
+
let (S.Step main) = S.step src "main.ml" |> Option.get in
55
+
Alcotest.(check (option string))
56
+
"main.ml" (Some "let () = ()") (S.get_block main);
56
57
57
58
(* Navigate doc *)
58
-
let doc = S.step c "doc" |> Option.get in
59
-
let guide = S.step doc "guide.md" |> Option.get in
60
-
Alcotest.(check (option string)) "guide" (Some "Usage guide") (S.get guide);
59
+
let (S.Step doc) = S.step c "doc" |> Option.get in
60
+
let (S.Step guide) = S.step doc "guide.md" |> Option.get in
61
+
Alcotest.(check (option string))
62
+
"guide" (Some "Usage guide") (S.get_block guide);
61
63
62
64
(* Path *)
63
65
Alcotest.(check (list string))
64
66
"guide path" [ "doc"; "guide.md" ] (S.path guide);
65
67
66
68
(* Up *)
67
-
let doc' = S.up guide |> Option.get in
69
+
let (S.Step doc') = S.up guide |> Option.get in
68
70
let doc_kids = S.list doc' |> List.map fst in
69
71
Alcotest.(check (list string)) "back to doc" [ "guide.md" ] doc_kids;
70
72
71
73
(* Proof *)
72
74
let proof, value =
73
75
S.produce heap Irmin_tar.tree root (fun c ->
74
-
let src = S.step c "src" |> Option.get in
75
-
let main = S.step src "main.ml" |> Option.get in
76
-
(main, S.get main))
76
+
let (S.Step src) = S.step c "src" |> Option.get in
77
+
let (S.Step main) = S.step src "main.ml" |> Option.get in
78
+
(S.Step main, S.get_block main))
77
79
in
78
80
Alcotest.(check (option string)) "proved" (Some "let () = ()") value;
79
81
match
80
82
S.verify proof Irmin_tar.tree (fun c ->
81
-
let src = S.step c "src" |> Option.get in
82
-
let main = S.step src "main.ml" |> Option.get in
83
-
(main, S.get main))
83
+
let (S.Step src) = S.step c "src" |> Option.get in
84
+
let (S.Step main) = S.step src "main.ml" |> Option.get in
85
+
(S.Step main, S.get_block main))
84
86
with
85
87
| Ok v -> Alcotest.(check (option string)) "verified" (Some "let () = ()") v
86
88
| Error (`Proof_failure msg) -> Alcotest.failf "verify: %s" msg
···
145
147
kids;
146
148
147
149
(* Step into package.json — dispatches to JSON codec *)
148
-
let pkg = S.step c "package.json" |> Option.get in
150
+
let (S.Step pkg) = S.step c "package.json" |> Option.get in
149
151
let pkg_kids = S.list pkg |> List.map fst |> List.sort String.compare in
150
152
Alcotest.(check (list string))
151
153
"package.json keys" [ "dependencies"; "name" ] pkg_kids;
152
154
153
155
(* Navigate into dependencies.fmt *)
154
-
let deps = S.step pkg "dependencies" |> Option.get in
155
-
let fmt_val = S.step deps "fmt" |> Option.get in
156
+
let (S.Step deps) = S.step pkg "dependencies" |> Option.get in
157
+
let (S.Step fmt_val) = S.step deps "fmt" |> Option.get in
156
158
Alcotest.(check (option string))
157
-
"fmt version" (Some {|"1.0"|}) (S.get fmt_val);
159
+
"fmt version" (Some {|"1.0"|}) (S.get_block fmt_val);
158
160
159
161
(* Full path *)
160
162
Alcotest.(check (list string))
···
164
166
165
167
(* Prove: "package.json has dependencies.digestif = '2.0'" *)
166
168
let read_digestif_version c =
167
-
let pkg = S.step c "package.json" |> Option.get in
168
-
let deps = S.step pkg "dependencies" |> Option.get in
169
-
let v = S.step deps "digestif" |> Option.get in
170
-
(v, S.get v)
169
+
let (S.Step pkg) = S.step c "package.json" |> Option.get in
170
+
let (S.Step deps) = S.step pkg "dependencies" |> Option.get in
171
+
let (S.Step v) = S.step deps "digestif" |> Option.get in
172
+
(S.Step v, S.get_block v)
171
173
in
172
174
let proof, value = S.produce heap tar_json root read_digestif_version in
173
175
Alcotest.(check (option string)) "proved digestif" (Some {|"2.0"|}) value;