├── .gitignore ├── .merlin ├── LICENSE ├── Makefile ├── README.md ├── _oasis ├── configure ├── examples ├── lww_test.ml ├── queue_test.ml ├── queue_test2.ml └── set_test.ml └── lib ├── builder.ml ├── builder.mli ├── irmin_datatypes.ml ├── lww_register.ml ├── lww_register.mli ├── merge_blob_set.ml ├── merge_blob_set.mli ├── merge_queue.ml └── merge_queue.mli /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | _build 3 | *.cmt 4 | *.swp 5 | *.log 6 | *.native 7 | *.docdir 8 | 9 | setup.data 10 | setup.log 11 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | S lib 2 | S examples 3 | 4 | B _build/lib 5 | B _build/examples 6 | 7 | PKG irmin 8 | PKG lwt 9 | PKG tc 10 | PKG core 11 | PKG git 12 | PKG alcotest 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, KC Sivaramakrishnan 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | 15 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # irmin-datatypes 2 | A collection of functional, mergeable datatypes for Irmin. Currently supports: 3 | 4 | * **LWW register** -- A last-writer-wins register based on write timestamps. 5 | * **Queue** -- An efficient double-ended queue. Uses liked representation on 6 | the append-only store. Provides O(1) push and pop operations. 7 | * **Set** -- A "naive" set implementation. Serializes the set into a single 8 | blob. 9 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | Name: irmin-datatypes 2 | Version: 0.1 3 | Synopsis: A collection of irmin datatypes 4 | Authors: KC Sivaramakrishnan 5 | License: ISC 6 | BuildTools: ocamlbuild 7 | OASISFormat: 0.4 8 | Plugins: META (0.4), DevFiles (0.4) 9 | 10 | Flag examples 11 | Description: build the examples 12 | Default: false 13 | 14 | Library "irmin-datatypes" 15 | Path: lib/ 16 | Findlibname: irmin_datatypes 17 | InternalModules: Lww_register, Merge_queue, Builder, Merge_blob_set 18 | Modules: Irmin_datatypes 19 | BuildDepends: lwt, irmin, tc, ezjsonm, bin_prot, core, ppx_jane 20 | ByteOpt: -thread 21 | NativeOpt: -thread 22 | 23 | Executable "lww_test" 24 | Path: examples/ 25 | MainIs: lww_test.ml 26 | Build$: flag(examples) 27 | CompiledObject: best 28 | Install: false 29 | BuildDepends: irmin, irmin_datatypes, irmin.unix, core 30 | ByteOpt: -thread 31 | NativeOpt: -thread 32 | 33 | Executable "queue_test" 34 | Path: examples 35 | MainIs: queue_test.ml 36 | Build$: flag(examples) 37 | CompiledObject: best 38 | Install: false 39 | BuildDepends: irmin_datatypes, irmin.unix, alcotest 40 | ByteOpt: -thread 41 | NativeOpt: -thread 42 | 43 | Executable "queue_test2" 44 | Path: examples 45 | MainIs: queue_test2.ml 46 | Build$: flag(examples) 47 | CompiledObject: best 48 | Install: false 49 | BuildDepends: irmin_datatypes, irmin.unix 50 | ByteOpt: -thread 51 | NativeOpt: -thread 52 | 53 | Executable "set_test" 54 | Path: examples 55 | MainIs: set_test.ml 56 | Build$: flag(examples) 57 | CompiledObject: best 58 | Install: false 59 | BuildDepends: irmin_datatypes, irmin.unix 60 | ByteOpt: -thread 61 | NativeOpt: -thread 62 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /examples/lww_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Testing LWW Register *) 18 | 19 | open Printf 20 | open Lwt 21 | open Irmin_unix 22 | open Irmin_datatypes 23 | 24 | let (>>=) = Lwt.bind 25 | 26 | module Path = Irmin.Path.String_list 27 | module Lww = Lww_register.Make(Tc.Int)(Path) 28 | module Store = 29 | Irmin.Make(Irmin_mem.AO)(Irmin_mem.RW)(Lww)(Irmin.Ref.String)(Irmin.Hash.SHA1) 30 | 31 | let key = ["local"; "Register"] 32 | 33 | let main () = 34 | let config = Irmin_git.config ~bare:true () in 35 | Store.Repo.create config >>= Store.master task >>= fun b1 -> 36 | 37 | Lww.create 0 >>= fun r0 -> 38 | Store.update (b1 "Set key to r0 (val = 0)") key r0 >>= fun () -> 39 | 40 | printf "Clone branch 1 into branch 2\n"; 41 | Store.clone_force task (b1 "cloning the store") "test" >>= fun b2 -> 42 | 43 | Store.read_exn (b2 "Fetch register") key >>= fun r1 -> 44 | Lww.update r1 1 >>= fun r2 -> 45 | Store.update (b2 "Set key to r2 (val = 1)") key r2 >>= fun () -> 46 | 47 | Store.read_exn (b1 "Fetch register") key >>= fun r3 -> 48 | Lww.read_reg r3 >>= fun v -> 49 | printf "Reg value before merge = %d\n" v; 50 | 51 | printf "Merge branch 2 into branch 1\n"; 52 | Store.merge_exn "Merge b2 into b1" b2 ~into:b1 >>= fun () -> 53 | 54 | Store.read_exn (b1 "Fetch register") key >>= fun r4 -> 55 | Lww.read_reg r4 >>= fun v -> 56 | printf "Reg value after merge = %d\n" v; return () 57 | 58 | let () = Lwt_unix.run (main ()) 59 | -------------------------------------------------------------------------------- /examples/queue_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Benjamin Farinier 3 | * Copyright (c) 2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Printf 19 | open Irmin_datatypes 20 | 21 | let (>>=) = Lwt.bind 22 | 23 | 24 | module Config = struct 25 | let conf = Irmin_git.config () 26 | let task = Irmin_unix.task 27 | end 28 | module Path = Irmin.Path.String_list 29 | 30 | module Queue = Merge_queue.Make(Irmin_mem.AO)(Irmin.Hash.SHA1)(Tc.Int)(Path)(Config) 31 | 32 | let assert_failure s = 33 | Printf.fprintf stderr "%s\n%!" s; 34 | assert false 35 | 36 | let assert_bool s b = 37 | if not b then assert_failure s 38 | 39 | type choice = 40 | | Top 41 | | Bot 42 | 43 | let () = 44 | Random.self_init () 45 | 46 | let get_val = 47 | let c = ref (-1) in 48 | (fun () -> incr c; !c) 49 | 50 | let choose lambda x = 51 | let p = exp (-. (float(x) /. float(lambda))) in 52 | if Random.float 1. < p then Top else Bot 53 | 54 | let rec clean q = 55 | Queue.is_empty q >>= fun b -> 56 | if b then Lwt.return q 57 | else 58 | Queue.pop_exn q >>= fun (_, q) -> 59 | clean q 60 | 61 | let assert_queue (q_old:Queue.t) (q1:Queue.t) (q2:Queue.t) (q_merge:Queue.t) = 62 | 63 | let rec prepare_old_merge q_old q1 q2 q_merge q_tmp = 64 | (*print_endline "prepare_old_merge";*) 65 | Queue.pop q_tmp >>= fun opt_tmp -> 66 | Queue.pop q_merge >>= fun opt_merge -> 67 | match (opt_tmp, opt_merge) with 68 | | None, None -> ( 69 | Queue.is_empty q1 >>= fun b1 -> 70 | Queue.is_empty q2 >>= fun b2 -> 71 | assert_bool "prepare_old_merge" (b1 && b2); 72 | Lwt.return () 73 | ) 74 | | None, Some (a_merge, q_merge') -> ( 75 | prepare_old_q1_q2 q_old q1 q2 q_merge 76 | ) 77 | | Some (a_tmp, q_tmp'), None -> ( 78 | prepare_old_q1_q2 q_old q1 q2 q_merge 79 | ) 80 | | Some (a_tmp, q_tmp'), Some (a_merge, q_merge') -> ( 81 | if (a_tmp = a_merge) then 82 | prepare_old_merge_continue q_old q1 q2 q_merge' q_tmp' 83 | else 84 | prepare_old_merge q_old q1 q2 q_merge q_tmp' 85 | ) 86 | 87 | and prepare_old_merge_continue q_old q1 q2 q_merge q_tmp = 88 | (*print_endline "prepare_old_merge_continue";*) 89 | Queue.pop q_tmp >>= fun opt_tmp -> 90 | Queue.pop q_merge >>= fun opt_merge -> 91 | match (opt_tmp, opt_merge) with 92 | | None, None -> ( 93 | Queue.is_empty q1 >>= fun b1 -> 94 | Queue.is_empty q2 >>= fun b2 -> 95 | assert_bool "prepare_old_merge_continue" (b1 && b2); 96 | Lwt.return () 97 | ) 98 | | None, Some (a_merge, q_merge') -> ( 99 | prepare_old_q1_q2 q_old q1 q2 q_merge 100 | ) 101 | | Some (a_tmp, q_tmp'), None -> ( 102 | prepare_old_q1_q2 q_old q1 q2 q_merge 103 | ) 104 | | Some (a_tmp, q_tmp'), Some (a_merge, q_merge') -> ( 105 | if (a_tmp = a_merge) then 106 | prepare_old_merge_continue q_old q1 q2 q_merge' q_tmp' 107 | else 108 | prepare_old_q1_q2 q_old q1 q2 q_merge 109 | ) 110 | 111 | and prepare_old_q1_q2 q_old q1 q2 q_merge = 112 | (*print_endline "prepare_old_q1_q2";*) 113 | Queue.pop q_old >>= fun opt_old -> 114 | Queue.pop q1 >>= fun opt1 -> 115 | Queue.pop q2 >>= fun opt2 -> 116 | match (opt_old, opt1, opt2) with 117 | | None, None, None -> ( 118 | Queue.is_empty q_merge >>= fun b -> 119 | assert_bool "prepare_old_q1_q2 (1)" b; 120 | Lwt.return () 121 | ) 122 | | None, None, Some (a2, q2') -> ( 123 | compare_q2_merge q2 q_merge 124 | ) 125 | | None, Some (a1, q1'), None -> ( 126 | compare_q1_merge q1 q_merge 127 | ) 128 | | None, Some (a1, q1'), Some (a2, q2') -> ( 129 | compare_q1_q2_merge q1 q2 q_merge 130 | ) 131 | | Some (a_old, q_old'), None, None -> ( 132 | Queue.is_empty q_merge >>= fun b -> 133 | assert_bool "prepare_old_q1_q2 (2)" b; 134 | Lwt.return () 135 | ) 136 | | Some (a_old, q_old'), None, Some (a2, q2') -> ( 137 | if (a_old = a2) then 138 | prepare_old_q2 q_old' q1 q2' q_merge 139 | else 140 | compare_q2_merge q2 q_merge 141 | ) 142 | | Some (a_old, q_old'), Some (a1, q1'), None -> ( 143 | if (a_old = a1) then 144 | prepare_old_q1 q_old' q1' q2 q_merge 145 | else 146 | compare_q1_merge q1 q_merge 147 | ) 148 | | Some (a_old, q_old'), Some (a1, q1'), Some (a2, q2') -> ( 149 | match (a_old = a1, a_old = a2) with 150 | | false, false -> prepare_old_q1_q2 q_old' q1 q2 q_merge 151 | | false, true -> prepare_old_q1_q2 q_old' q1 q2' q_merge 152 | | true, false -> prepare_old_q1_q2 q_old' q1' q2 q_merge 153 | | true, true -> prepare_old_q1_q2 q_old' q1' q2' q_merge 154 | ) 155 | 156 | and prepare_old_q1 q_old q1 q2 q_merge = 157 | (*print_endline "prepare_old_q1";*) 158 | Queue.pop q_old >>= fun opt_old -> 159 | Queue.pop q1 >>= fun opt1 -> 160 | match (opt_old, opt1) with 161 | | None, None -> ( 162 | Queue.is_empty q_merge >>= fun b -> 163 | assert_bool "prepare_old_q1 (1)" b; 164 | Lwt.return () 165 | ) 166 | | None, Some (a1, q1') -> ( 167 | compare_q1_q2_merge q1 q2 q_merge 168 | ) 169 | | Some (a_old, q_old'), None -> ( 170 | Queue.is_empty q_merge >>= fun b -> 171 | assert_bool "prepare_old_q1 (2)" b; 172 | Lwt.return () 173 | ) 174 | | Some (a_old, q_old'), Some (a1, q1') -> ( 175 | assert_bool "prepare_old_q1 (3)" (a_old = a1); 176 | prepare_old_q1 q_old' q1' q2 q_merge 177 | ) 178 | 179 | and prepare_old_q2 q_old q1 q2 q_merge = 180 | (*print_endline "prepare_old_q2";*) 181 | Queue.pop q_old >>= fun opt_old -> 182 | Queue.pop q2 >>= fun opt2 -> 183 | match (opt_old, opt2) with 184 | | None, None -> ( 185 | Queue.is_empty q_merge >>= fun b -> 186 | assert_bool "prepare_old_q2 (1)" b; 187 | Lwt.return () 188 | ) 189 | | None, Some (a2, q2') -> ( 190 | compare_q1_q2_merge q1 q2 q_merge 191 | ) 192 | | Some (a_old, q_old'), None -> ( 193 | Queue.is_empty q_merge >>= fun b -> 194 | assert_bool "prepare_old_q2 (2)" b; 195 | Lwt.return () 196 | ) 197 | | Some (a_old, q_old'), Some (a2, q2') -> ( 198 | assert_bool "prepare_old_q2 (3)" (a_old = a2); 199 | prepare_old_q2 q_old' q1 q2' q_merge 200 | ) 201 | 202 | and compare_q1_q2_merge q1 q2 q_merge = 203 | (*print_endline "compare_q1_q2_merge";*) 204 | Queue.pop q1 >>= fun opt1 -> 205 | Queue.pop q2 >>= fun opt2 -> 206 | Queue.pop q_merge >>= fun opt_merge -> 207 | match (opt1, opt2, opt_merge) with 208 | | None, None, None -> Lwt.return () 209 | | None, None, Some (a_merge, q_merge') -> 210 | assert_failure "compare_q1_q2_merge (1)" 211 | | None, Some (a2, q2'), None -> 212 | assert_failure "compare_q1_q2_merge (2)" 213 | | None, Some (a2, q2'), Some (a_merge, q_merge') -> 214 | assert_bool "compare_q1_q2_merge (3)" (a2 = a_merge); 215 | compare_q2_merge q2' q_merge' 216 | | Some (a1, q1'), None, None -> 217 | assert_failure "compare_q1_q2_merge (4)" 218 | | Some (a1, q1'), None, Some (a_merge, q_merge') -> 219 | assert_bool "compare_q1_q2_merge" (a1 = a_merge); 220 | compare_q1_merge q1' q_merge' 221 | | Some (a1, q1'), Some (a2, q2'), None -> 222 | assert_failure "compare_q1_q2_merge (5)" 223 | | Some (a1, q1'), Some (a2, q2'), Some (a_merge, q_merge') -> 224 | assert_bool "compare_q1_q2_merge" (a1 = a_merge); 225 | compare_q1_q2_merge q1' q2 q_merge' 226 | 227 | and compare_q1_merge q1 q_merge = 228 | (*print_endline "compare_q1_merge";*) 229 | Queue.pop q1 >>= fun opt1 -> 230 | Queue.pop q_merge >>= fun opt_merge -> 231 | match (opt1, opt_merge) with 232 | | None, None -> Lwt.return () 233 | | None, Some (a_merge, q_merge') -> 234 | assert_failure "compare_q1_merge (1)" 235 | | Some (a1, q1'), None -> 236 | assert_failure "compare_q1_merge (2)" 237 | | Some (a1, q1'), Some (a_merge, q_merge') -> 238 | assert_bool "compare_q1_merge (3)" (a1 = a_merge); 239 | compare_q1_merge q1' q_merge' 240 | 241 | and compare_q2_merge q2 q_merge= 242 | (*print_endline "compare_q2_merge";*) 243 | Queue.pop q2 >>= fun opt2 -> 244 | Queue.pop q_merge >>= fun opt_merge -> 245 | match (opt2, opt_merge) with 246 | | None, None -> Lwt.return () 247 | | None, Some (a_merge, q_merge') -> 248 | assert_failure "compare_q2_merge (1)" 249 | | Some (a2, q2'), None -> 250 | assert_failure "compare_q2_merge (2)" 251 | | Some (a2, q2'), Some (a_merge, q_merge') -> 252 | assert_bool "compare_q2_merge" (a2 = a_merge); 253 | compare_q2_merge q2' q_merge' 254 | in 255 | prepare_old_merge q_old q1 q2 q_merge q_old 256 | 257 | let rec filling queue lambda count push pop = 258 | match choose lambda count with 259 | | Top -> ( 260 | match choose lambda (push - pop) with 261 | | Top ->( 262 | Queue.push queue (get_val ()) >>= fun queue -> 263 | filling queue lambda (count + 1) (push + 1) pop 264 | ) 265 | | Bot -> ( 266 | Queue.pop_exn queue >>= fun (_, queue) -> 267 | filling queue lambda count push (pop + 1) 268 | ) 269 | ) 270 | | Bot -> Lwt.return (queue, count, push, pop) 271 | 272 | and branching queue lambda mu nu push pop branch depth = 273 | building queue lambda mu nu push pop branch (depth + 1) >>= fun q1 -> 274 | match choose mu branch with 275 | | Top -> ( 276 | branching queue lambda mu nu push pop (branch + 1) depth >>= fun q2 -> 277 | let old () = Lwt.return @@ `Ok (Some (Some queue)) in 278 | Queue.merge [] ~old (Some q1) (Some q2) >>= function 279 | | `Conflict s -> assert_failure s 280 | | `Ok None -> assert_failure "branching: none" 281 | | `Ok Some (merge_q) -> 282 | assert_queue queue q1 q2 merge_q >>= fun () -> 283 | Lwt.return merge_q 284 | ) 285 | | Bot -> Lwt.return q1 286 | 287 | and building queue lambda mu nu push pop branch depth = 288 | filling queue lambda 0 push pop >>= fun (queue, count, push, pop) -> 289 | match choose nu depth with 290 | | Top -> branching queue lambda mu nu push pop branch depth 291 | | Bot -> Lwt.return queue 292 | 293 | let make lambda mu nu = 294 | Queue.create () >>= fun queue -> 295 | building queue lambda mu nu 0 0 0 0 >>= fun _ -> 296 | Lwt.return () 297 | 298 | let () = 299 | let suite = [ 300 | `Quick, 10 , 10 , 4; 301 | `Quick, 100, 4, 10; 302 | `Quick, 100, 2, 20; 303 | `Slow , 100, 10, 10; 304 | ] in 305 | let test_cases = 306 | List.map (fun (q, lambda, mu, nu) -> 307 | Printf.sprintf "lambda=%d mu=%d nu=%d" lambda mu nu, 308 | q, 309 | fun () -> Lwt_unix.run (make lambda mu nu) 310 | ) suite in 311 | Alcotest.run "mqueue" [ "GIT-MEMORY", test_cases ] 312 | -------------------------------------------------------------------------------- /examples/queue_test2.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Testing LWW Register *) 18 | 19 | open Printf 20 | open Lwt 21 | open Irmin_unix 22 | open Irmin_datatypes 23 | 24 | let (>>=) = Lwt.bind 25 | 26 | module Config = struct 27 | let conf = Irmin_git.config () 28 | let task = task 29 | end 30 | module Path = Irmin.Path.String_list 31 | module Queue = Merge_queue.Make(Irmin_mem.AO)(Irmin.Hash.SHA1)(Tc.Int)(Path)(Config) 32 | module Store = 33 | Irmin.Make(Irmin_mem.AO)(Irmin_mem.RW)(Queue)(Irmin.Ref.String)(Irmin.Hash.SHA1) 34 | 35 | let key = ["local"; "queue"] 36 | 37 | let main () = 38 | let config = Irmin_git.config ~bare:true () in 39 | Store.Repo.create config >>= Store.master task >>= fun b1 -> 40 | 41 | Queue.create () >>= fun q1 -> 42 | Queue.push q1 0 >>= fun q2 -> 43 | Store.update (b1 "Set key to q2 (len = 1)") key q2 >>= fun () -> 44 | 45 | printf "Clone branch 1 into branch 2\n"; 46 | Store.clone_force Config.task (b1 "cloning the store") "test" >>= fun b2 -> 47 | 48 | Store.read_exn (b2 "Fetch queue") key >>= fun q3 -> 49 | Queue.push q3 1 >>= fun q4 -> 50 | Store.update (b2 "Set key to q4 (len = 2)") key q4 >>= fun () -> 51 | 52 | printf "Merge branch 2 into branch 1\n"; 53 | Store.merge_exn "Merge b2 into b1" b2 ~into:b1 >>= fun () -> 54 | 55 | Store.read_exn (b1 "Fetch queue") key >>= fun q5 -> 56 | Queue.length q5 >>= fun l -> 57 | printf "Queue length = %d\n" l; return () 58 | 59 | let () = Lwt_unix.run (main ()) 60 | -------------------------------------------------------------------------------- /examples/set_test.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* Testing LWW Register *) 18 | 19 | open Printf 20 | open Lwt 21 | open Irmin_unix 22 | open Irmin_datatypes 23 | 24 | let (>>=) = Lwt.bind 25 | 26 | module Config = struct 27 | let conf = Irmin_git.config () 28 | let task = task 29 | end 30 | module Path = Irmin.Path.String_list 31 | module Set = Merge_blob_set.Make(Irmin_mem.AO)(Irmin.Hash.SHA1)(Tc.Int)(Path)(Config) 32 | module Store = 33 | Irmin.Make(Irmin_mem.AO)(Irmin_mem.RW)(Set)(Irmin.Ref.String)(Irmin.Hash.SHA1) 34 | 35 | let key = ["local"; "set"] 36 | 37 | let main () = 38 | let config = Irmin_git.config ~bare:true () in 39 | Store.Repo.create config >>= Store.master task >>= fun b1 -> 40 | 41 | Set.create () >>= fun s -> 42 | Set.add s 0 >>= fun s -> 43 | Set.add s 1 >>= fun s -> 44 | Store.update (b1 "update") key s >>= fun () -> 45 | Set.dump s >>= fun eltList -> 46 | printf "Initial set = "; 47 | List.iter (printf "%d ") eltList; 48 | printf "\n"; 49 | 50 | printf "Clone branch 1 into branch 2\n"; 51 | Store.clone_force Config.task (b1 "cloning the store") "test" >>= fun b2 -> 52 | 53 | Set.remove s 0 >>= fun s -> 54 | Set.add s 2 >>= fun s -> 55 | Store.update (b1 "update") key s >>= fun () -> 56 | Set.dump s >>= fun eltList -> 57 | printf "Set on branch 1 = "; 58 | List.iter (printf "%d ") eltList; 59 | printf "(removed 0, added 2)\n"; 60 | 61 | Store.read_exn (b2 "Fetch set") key >>= fun s -> 62 | Set.remove s 1 >>= fun s -> 63 | Set.add s 3 >>= fun s -> 64 | Store.update (b2 "update") key s >>= fun () -> 65 | Set.dump s >>= fun eltList -> 66 | printf "Set on branch 2 = "; 67 | List.iter (printf "%d ") eltList; 68 | printf "(removed 1, added 3)\n"; 69 | 70 | printf "Merge branch 2 into branch 1\n"; 71 | Store.merge_exn "Merge b2 into b1" b2 ~into:b1 >>= fun () -> 72 | 73 | Store.read_exn (b1 "Fetch set") key >>= fun s -> 74 | Set.dump s >>= fun eltList -> 75 | printf "Merged list = "; 76 | List.iter (printf "%d ") eltList; 77 | printf "\n"; return () 78 | 79 | 80 | let () = Lwt_unix.run (main ()) 81 | -------------------------------------------------------------------------------- /lib/builder.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Irmin.Merge.OP 19 | 20 | module type DIFF = sig 21 | include Tc.S0 22 | type diff 23 | val patch : diff -> t -> t Lwt.t 24 | val diff : t -> t -> diff Lwt.t 25 | end 26 | 27 | module Make (D: DIFF) (P: Irmin.Path.S) = struct 28 | include D 29 | module Path = P 30 | 31 | let merge: Path.t -> t option Irmin.Merge.t = 32 | let merge ~old v1 v2 = 33 | old () >>= function 34 | | `Conflict _ | `Ok None -> conflict "merge" 35 | | `Ok (Some old) -> 36 | diff v2 old >>= fun d2 -> 37 | patch d2 v1 >>= fun res -> 38 | ok res 39 | in fun _path -> Irmin.Merge.option (module D) merge 40 | end 41 | -------------------------------------------------------------------------------- /lib/builder.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module type DIFF = sig 18 | include Tc.S0 19 | (** The type of base. *) 20 | 21 | type diff 22 | (** The type of diff. *) 23 | 24 | val patch : diff -> t -> t Lwt.t 25 | (** Apply a patch. Patch must always be accepted. *) 26 | 27 | val diff : t -> t -> diff Lwt.t 28 | (** Obtain a diff between two versions. *) 29 | end 30 | 31 | module Make 32 | (D: DIFF) 33 | (P: Irmin.Path.S) 34 | : Irmin.Contents.S 35 | with type t = D.t 36 | and module Path = P 37 | -------------------------------------------------------------------------------- /lib/irmin_datatypes.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | module Lww_register = Lww_register 18 | module Merge_queue = Merge_queue 19 | module Merge_blob_set = Merge_blob_set 20 | 21 | module Builder = Builder 22 | -------------------------------------------------------------------------------- /lib/lww_register.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* A last-write-wins register *) 18 | 19 | open Lwt 20 | open Core 21 | open Core.Std 22 | open Irmin.Merge.OP 23 | 24 | type stats = { 25 | ops: int; 26 | reads: int; 27 | writes: int; 28 | } 29 | 30 | let string_of_stats t = 31 | Printf.sprintf "%i\t%f\t%f%!" 32 | t.ops 33 | ((float t.reads) /. (float t.ops)) 34 | ((float t.writes) /. (float t.ops)) 35 | 36 | module type TIME = module type of Time 37 | 38 | module Time = struct 39 | include Tc.Bin_prot0 (struct 40 | include Time 41 | let to_json v = Ezjsonm.float @@ to_float v 42 | let of_json v = of_float @@ Ezjsonm.get_float v 43 | let bin_size_t v = Bin_prot.Size.bin_size_float @@ to_float v 44 | let bin_write_t a ~pos c = Bin_prot.Write.bin_write_float a ~pos (to_float c) 45 | let bin_read_t a ~pos_ref = Bin_prot.Read.bin_read_float a ~pos_ref |> of_float 46 | end) 47 | include (Time : TIME with type t := t) 48 | end 49 | 50 | module type Config = sig 51 | val conf : Irmin.config 52 | val task: string -> Irmin.task 53 | end 54 | 55 | module type S = sig 56 | type value 57 | include Irmin.Contents.S 58 | val create : value -> t Lwt.t 59 | val read_reg : t -> value Lwt.t 60 | val update : t -> value -> t Lwt.t 61 | val stats : unit -> stats 62 | end 63 | 64 | module Make 65 | (V: Tc.S0) 66 | (P: Irmin.Path.S) 67 | = struct 68 | 69 | type value = V.t 70 | module Path = P 71 | 72 | module M = Tc.Pair (Time)(V) 73 | include M 74 | 75 | let compare (x,u) (y,v) = 76 | let r = Time.compare x y in 77 | if r = 0 then V.compare u v else r 78 | 79 | let to_raw v = Tc.write_cstruct (module M) v 80 | let of_raw cs = Tc.read_cstruct (module M) cs 81 | 82 | let (incr_read, incr_write, get_read, get_write) = 83 | let count_read = ref 0 in 84 | let count_write = ref 0 in 85 | ( 86 | (fun () -> incr count_read), 87 | (fun () -> incr count_write), 88 | (fun () -> !count_read), 89 | (fun () -> !count_write) 90 | ) 91 | 92 | let create v = return (Time.now (), v) 93 | 94 | let read_reg (_,v) = return v 95 | 96 | let update (_,v) v' = return (Time.now (), v') 97 | 98 | let merge : Path.t -> t option Irmin.Merge.t = 99 | let merge ~old v1 v2 = 100 | if compare v1 v2 > 0 then ok v1 else ok v2 101 | in fun _path -> Irmin.Merge.option (module M) merge 102 | 103 | let stats () = 104 | let reads = get_read () in 105 | let writes = get_write () in 106 | { ops = reads + writes; reads; writes } 107 | 108 | end 109 | -------------------------------------------------------------------------------- /lib/lww_register.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (* A last-write-wins register *) 18 | 19 | type stats = { 20 | ops: int; 21 | reads : int; 22 | writes : int; 23 | } 24 | (** Statistic values. *) 25 | 26 | val string_of_stats: stats -> string 27 | (** Pretty-print the stats. *) 28 | 29 | module type S = sig 30 | 31 | include Irmin.Contents.S 32 | (** The type of LWW register. *) 33 | 34 | type value 35 | (** The type of value stored in the LWW register. *) 36 | 37 | val create : value -> t Lwt.t 38 | (** Create a new register with the given key. *) 39 | 40 | val read_reg : t -> value Lwt.t 41 | (** Read the register. *) 42 | 43 | val update : t -> value -> t Lwt.t 44 | (** Update the value of register. *) 45 | 46 | val stats : unit -> stats 47 | (** Obtain global statistics on register operations *) 48 | end 49 | 50 | module type Config = sig 51 | val conf : Irmin.config 52 | val task : string -> Irmin.task 53 | end 54 | 55 | module Make 56 | (V: Tc.S0) 57 | (P: Irmin.Path.S) 58 | : S with type value = V.t 59 | and module Path = P 60 | -------------------------------------------------------------------------------- /lib/merge_blob_set.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | open Lwt 18 | open Irmin.Merge.OP 19 | 20 | let list_dedup ?(compare=Pervasives.compare) t = 21 | let t = List.sort compare t in 22 | let rec aux acc = function 23 | | [] -> List.rev acc 24 | | [x] -> aux (x :: acc) [] 25 | | x::(y::_ as tl) -> 26 | match compare x y with 27 | | 0 -> aux acc tl 28 | | _ -> aux (x :: acc) tl 29 | in 30 | aux [] t 31 | 32 | exception Empty 33 | 34 | type stats = { 35 | ops: int; 36 | reads: int; 37 | writes: int; 38 | } 39 | 40 | let string_of_stats t = 41 | Printf.sprintf "%i\t%f\t%f%!" 42 | t.ops 43 | ((float t.reads) /. (float t.ops)) 44 | ((float t.writes) /. (float t.ops)) 45 | 46 | module type S = sig 47 | include Irmin.Contents.S 48 | type elt 49 | val create : unit -> t Lwt.t 50 | val cardinal : t -> int Lwt.t 51 | val is_empty : t -> bool Lwt.t 52 | val add : t -> elt -> t Lwt.t 53 | val remove : t -> elt -> t Lwt.t 54 | val mem : t -> elt -> bool Lwt.t 55 | val dump : t -> elt list Lwt.t 56 | val stats : unit -> stats 57 | end 58 | 59 | module type Config = sig 60 | val conf: Irmin.config 61 | val task: string -> Irmin.task 62 | end 63 | 64 | module Make 65 | (AO: Irmin.AO_MAKER) 66 | (K: Irmin.Hash.S) 67 | (V: Tc.S0) 68 | (P: Irmin.Path.S) 69 | (Config: Config) 70 | = struct 71 | 72 | module C = struct 73 | 74 | module Tc_set = Tc.Set(V) 75 | include Tc_set 76 | 77 | type diff = {adds: Tc_set.t; removes: Tc_set.t} 78 | 79 | module S = Set.Make(V) 80 | 81 | let diff s1 s2 = 82 | return {adds = S.diff s1 s2; 83 | removes = S.diff s2 s1} 84 | 85 | let patch d s = 86 | return @@ S.diff (S.union s d.adds) d.removes 87 | end 88 | 89 | let (incr_read, incr_write, get_read, get_write) = 90 | let count_read = ref 0 in 91 | let count_write = ref 0 in 92 | ( 93 | (fun () -> incr count_read), 94 | (fun () -> incr count_write), 95 | (fun () -> !count_read), 96 | (fun () -> !count_write) 97 | ) 98 | 99 | module Store = struct 100 | 101 | module S = AO(K)(C) 102 | 103 | include S 104 | 105 | let create () = 106 | create Config.conf 107 | 108 | let read t k = 109 | incr_read (); 110 | S.read t k 111 | 112 | let read_exn t k = 113 | incr_read (); 114 | S.read_exn t k 115 | 116 | let read_free t k = 117 | S.read_exn t k 118 | 119 | let add t v = 120 | incr_write (); 121 | S.add t v 122 | 123 | end 124 | 125 | type set = { card : int; root : K.t } 126 | module SetV = Set.Make(V) 127 | 128 | module S = struct 129 | 130 | module T = Tc.Biject (Tc.Pair(Tc.Int)(K)) 131 | (struct 132 | type t = set 133 | let to_t (card, root) = {card; root} 134 | let of_t {card; root} = (card, root) 135 | end) 136 | include T 137 | 138 | type diff = C.diff 139 | 140 | let diff {root = r1; _} {root = r2; _} = 141 | Store.create () >>= fun store -> 142 | Store.read_exn store r1 >>= fun s1 -> 143 | Store.read_exn store r2 >>= fun s2 -> 144 | C.diff s1 s2 145 | 146 | let patch d {root; _} = 147 | Store.create () >>= fun store -> 148 | Store.read_exn store root >>= fun s -> 149 | C.patch d s >>= fun res_set -> 150 | Store.add store res_set >>= fun new_root -> 151 | return {root = new_root; card = SetV.cardinal res_set} 152 | end 153 | 154 | include Builder.Make(S)(P) 155 | 156 | type elt = V.t 157 | 158 | let is_empty { card; _ } = return (card == 0) 159 | let cardinal { card; _} = return card 160 | 161 | let dump { card; root } = 162 | if card == 0 then return [] 163 | else Store.create () >>= fun store -> 164 | Store.read_exn store root >>= fun set -> 165 | return @@ SetV.elements set 166 | 167 | let create () = 168 | Store.create () >>= fun store -> 169 | Store.add store (SetV.empty) >>= fun root -> 170 | return {card = 0; root} 171 | 172 | let add {root; _} elt = 173 | Store.create () >>= fun store -> 174 | Store.read_exn store root >>= fun set_val -> 175 | let new_set = SetV.add elt set_val in 176 | let card = SetV.cardinal new_set in 177 | Store.add store new_set >>= fun new_root -> 178 | return @@ {root = new_root; card} 179 | 180 | let remove {root; _} elt = 181 | Store.create () >>= fun store -> 182 | Store.read_exn store root >>= fun set_val -> 183 | let new_set = SetV.remove elt set_val in 184 | let card = SetV.cardinal new_set in 185 | Store.add store new_set >>= fun new_root -> 186 | return @@ {root = new_root; card} 187 | 188 | let mem {root; _} elt = 189 | Store.create () >>= fun store -> 190 | Store.read_exn store root >>= fun set_val -> 191 | return @@ SetV.mem elt set_val 192 | 193 | let stats () = 194 | let reads = get_read () in 195 | let writes = get_write () in 196 | { ops = reads + writes; reads; writes } 197 | end 198 | -------------------------------------------------------------------------------- /lib/merge_blob_set.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2015 KC Sivaramakrishnan 3 | * 4 | * Permission to use, copy, modify, and distribute this software for any 5 | * purpose with or without fee is hereby granted, provided that the above 6 | * copyright notice and this permission notice appear in all copies. 7 | * 8 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | *) 16 | 17 | (** A naive implementation of mergeable sets. *) 18 | 19 | type stats = { 20 | ops: int; 21 | reads : int; 22 | writes : int; 23 | } 24 | (** Statistic values. *) 25 | 26 | val string_of_stats: stats -> string 27 | (** Pretty-print the stats. *) 28 | 29 | module type S = sig 30 | 31 | type elt 32 | (** The elements of the sets. *) 33 | 34 | include Irmin.Contents.S 35 | (** The type of sets. *) 36 | 37 | val create : unit -> t Lwt.t 38 | (** Create a new set. *) 39 | 40 | val cardinal : t -> int Lwt.t 41 | (** Return the size of the set [t]. *) 42 | 43 | val is_empty : t -> bool Lwt.t 44 | (** Return true if the given set [t] is empty, false 45 | otherwise. *) 46 | 47 | val add : t -> elt -> t Lwt.t 48 | (** Returns a set with [elt] added. *) 49 | 50 | val remove : t -> elt -> t Lwt.t 51 | (** Returns a set with [elt] removed. *) 52 | 53 | val mem : t -> elt -> bool Lwt.t 54 | (** Returns true if [elt] is present in the set. *) 55 | 56 | val dump : t -> elt list Lwt.t 57 | (** Dump the contents of the set. *) 58 | 59 | val stats : unit -> stats 60 | (** Print global statistics on set operations. *) 61 | 62 | end 63 | 64 | module type Config = sig 65 | val conf: Irmin.config 66 | val task: string -> Irmin.task 67 | end 68 | 69 | module Make 70 | (AO: Irmin.AO_MAKER) 71 | (K: Irmin.Hash.S) 72 | (V: Tc.S0) 73 | (P: Irmin.Path.S) 74 | (C: Config) 75 | : S with type elt = V.t 76 | and module Path = P 77 | -------------------------------------------------------------------------------- /lib/merge_queue.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Benjamin Farinier 3 | * Copyright (c) 2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | open Lwt 19 | open Irmin.Merge.OP 20 | 21 | let list_dedup ?(compare=Pervasives.compare) t = 22 | let t = List.sort compare t in 23 | let rec aux acc = function 24 | | [] -> List.rev acc 25 | | [x] -> aux (x :: acc) [] 26 | | x::(y::_ as tl) -> 27 | match compare x y with 28 | | 0 -> aux acc tl 29 | | _ -> aux (x :: acc) tl 30 | in 31 | aux [] t 32 | 33 | exception Empty 34 | 35 | type error = [ `Corrupted | `Invalid_access ] 36 | exception Error of error 37 | 38 | type stats = { 39 | ops: int; 40 | reads: int; 41 | writes: int; 42 | } 43 | 44 | let string_of_stats t = 45 | Printf.sprintf "%i\t%f\t%f%!" 46 | t.ops 47 | ((float t.reads) /. (float t.ops)) 48 | ((float t.writes) /. (float t.ops)) 49 | 50 | module type S = sig 51 | include Irmin.Contents.S 52 | type elt 53 | val create : unit -> t Lwt.t 54 | val length : t -> int Lwt.t 55 | val is_empty : t -> bool Lwt.t 56 | val push : t -> elt -> t Lwt.t 57 | val pop_exn : t -> (elt * t) Lwt.t 58 | val pop : t -> (elt * t) option Lwt.t 59 | val peek_exn : t -> (elt * t) Lwt.t 60 | val peek : t -> (elt * t) option Lwt.t 61 | val dump : t -> string Lwt.t 62 | val stats : t -> stats 63 | end 64 | 65 | module type Config = sig 66 | val conf: Irmin.config 67 | val task: string -> Irmin.task 68 | end 69 | 70 | module Make 71 | (AO: Irmin.AO_MAKER) 72 | (K: Irmin.Hash.S) 73 | (V: Tc.S0) 74 | (P: Irmin.Path.S) 75 | (Config: Config) 76 | = struct 77 | 78 | module Path = P 79 | 80 | module C = struct 81 | 82 | (* 83 | * Type of index, which are queue accessor. 84 | * 'push' is the number of push applied to the queue since its creation, 85 | * 'pop' is the number of pop applied to the queue since its creation, 86 | * 'top' is the key of the queue top element, 87 | * 'bottom' is the key of the queue bottom element. 88 | *) 89 | type index = { 90 | push : int; 91 | pop : int; 92 | top : K.t; 93 | bottom: K.t; 94 | } 95 | 96 | module Index = Tc.Biject 97 | (Tc.Pair (Tc.Pair(Tc.Int)(Tc.Int))(Tc.Pair (K)(K))) 98 | (struct 99 | type t = index 100 | let to_t ((push, pop), (top, bottom)) = {push; pop; top; bottom} 101 | let of_t {push; pop; top; bottom} = (push, pop), (top, bottom) 102 | end) 103 | 104 | (* 105 | * Type of node, which are elements manipulated by queue operations. 106 | * 'next' is the optional key of a next element in the queue, 107 | * 'previous' is the optional key of a previous element in the queue, 108 | * 'elt' is the optional key of a elt associated to the node. 109 | *) 110 | type node = { 111 | next : K.t option; 112 | previous: K.t option; 113 | elt : K.t option; 114 | branch : index option; 115 | } 116 | 117 | module KO = Tc.Option (K) 118 | module Node = Tc.Biject 119 | (Tc.Pair(Tc.Pair(KO)(KO))(Tc.Pair(KO)(Tc.Option(Index)))) 120 | (struct 121 | type t = node 122 | let to_t ((next, previous), (elt, branch)) = 123 | {next; previous; elt; branch} 124 | let of_t {next; previous; elt; branch} = 125 | (next, previous), (elt, branch) 126 | end) 127 | 128 | (* 129 | * Type of store elements. 130 | *) 131 | type t = 132 | | Index of Index.t 133 | | Node of Node.t 134 | | Elt of V.t 135 | [@@deriving compare] 136 | 137 | let equal_node n1 n2 = 138 | Node.compare n1 n2 = 0 139 | 140 | let to_json = function 141 | | Index i -> `O [ "index", Index.to_json i ] 142 | | Node n -> `O [ "node" , Node.to_json n ] 143 | | Elt e -> `O [ "elt" , V.to_json e ] 144 | 145 | let of_json = function 146 | | `O [ "index", j ] -> Index (Index.of_json j) 147 | | `O [ "node" , j ] -> Node (Node.of_json j) 148 | | `O [ "elt" , j ] -> Elt (V.of_json j) 149 | | j -> Ezjsonm.parse_error j "C.of_json" 150 | 151 | let equal x y = match x, y with 152 | | Index x, Index y -> Index.equal x y 153 | | Node x, Node y -> Node.equal x y 154 | | Elt x, Elt y -> V.equal x y 155 | | _ -> false 156 | 157 | let hash = Hashtbl.hash 158 | 159 | (* FIXME: slow *) 160 | let to_string t = Ezjsonm.to_string (to_json t) 161 | let of_string s = of_json (Ezjsonm.from_string s) 162 | let write t buf = 163 | let str = to_string t in 164 | let len = String.length str in 165 | Cstruct.blit_from_string str 0 buf 0 len; 166 | Cstruct.shift buf len 167 | let read buf = 168 | Mstruct.get_string buf (Mstruct.length buf) 169 | |> of_string 170 | let size_of t = 171 | let str = to_string t in 172 | String.length str 173 | 174 | end 175 | 176 | let (incr_read, incr_write, get_read, get_write) = 177 | let count_read = ref 0 in 178 | let count_write = ref 0 in 179 | ( 180 | (fun () -> incr count_read), 181 | (fun () -> incr count_write), 182 | (fun () -> !count_read), 183 | (fun () -> !count_write) 184 | ) 185 | 186 | module Store = struct 187 | 188 | module S = AO(K)(C) 189 | 190 | include S 191 | 192 | let create () = 193 | create Config.conf 194 | 195 | let read t k = 196 | incr_read (); 197 | S.read t k 198 | 199 | let read_exn t k = 200 | incr_read (); 201 | S.read_exn t k 202 | 203 | let read_free t k = 204 | S.read_exn t k 205 | 206 | let add t v = 207 | incr_write (); 208 | S.add t v 209 | 210 | end 211 | 212 | (* 213 | * Type of a queue. 214 | * 'index' is the index of the queue in its store, 215 | * 'root' is the key of the 'empty' element of store. 216 | *) 217 | type queue = { 218 | index: C.Index.t; 219 | root : K.t; 220 | } 221 | 222 | module T = Tc.Biject (Tc.Pair (C.Index)(K)) 223 | (struct 224 | type t = queue 225 | let to_t (index, root) = {index; root} 226 | let of_t {index; root} = (index, root) 227 | end) 228 | include T 229 | 230 | type elt = V.t 231 | 232 | let empty = { 233 | C.next = None; 234 | C.previous = None; 235 | C.elt = None; 236 | C.branch = None; 237 | } 238 | 239 | (* 240 | * Create a new queue in the store 'store'. 241 | * 'top' and 'bottom' are pointed on the 'empty' node. 242 | *) 243 | let create () = 244 | Store.create () >>= fun store -> 245 | Store.add store (C.Node empty) >>= fun root -> 246 | let index = { 247 | C.push = 0; 248 | C.pop = 0; 249 | C.top = root; 250 | C.bottom = root; 251 | } in 252 | return { index; root } 253 | 254 | let length t = 255 | return (t.index.C.push - t.index.C.pop) 256 | 257 | let is_empty t = 258 | return (t.index.C.push = t.index.C.pop) 259 | 260 | (* 261 | * Queues are implemented with two lists, 262 | * the push list, containing pushed elements, 263 | * and the pop list, containing elements to be poped. 264 | * 'normalise' flush the push list into the pop one. 265 | *) 266 | let normalize q = 267 | Store.create () >>= fun store -> 268 | let index = q.index in 269 | let root = q.root in 270 | 271 | let apply k1 k2 queue old_node k_old_node k_new_node = 272 | k1 queue old_node k_old_node k_new_node k2 273 | in 274 | 275 | (* 276 | * Go through the pop list and call the continuation on the push list, 277 | * then rebuild it from its last element to its first element. 278 | * Not tail recursive. 279 | *) 280 | let rec from_top queue old_node k_old_node k_new_node k = 281 | 282 | (match old_node.C.next with 283 | | None -> ( 284 | assert (C.equal_node old_node empty); 285 | k queue k_old_node k_new_node 286 | ) 287 | | Some old_next -> ( 288 | Store.read_exn store old_next >>= fun old_next -> 289 | match old_next with 290 | | C.Index _ 291 | | C.Elt _ -> fail (Error `Corrupted) 292 | | C.Node old_next -> from_top queue old_next k_old_node k_new_node k 293 | ) 294 | ) >>= fun new_next -> 295 | match old_node.C.elt with 296 | | None -> return new_next 297 | | Some elt -> ( 298 | Store.add store (C.Node new_next) >>= fun new_key_node -> 299 | let new_node = { 300 | C.next = Some new_key_node; 301 | C.previous = None; 302 | C.elt = Some elt; 303 | C.branch = None; 304 | } in return new_node 305 | ) 306 | in 307 | 308 | (* 309 | * Go through the push list rebuilding its elements, then call the continuation. 310 | * Tail recursive. 311 | *) 312 | let rec from_bottom queue old_node new_node = 313 | 314 | match old_node.C.branch with 315 | | Some index -> ( 316 | Store.read_exn store index.C.top >>= fun branch_top -> 317 | match branch_top with 318 | | C.Index _ 319 | | C.Elt _ -> fail (Error `Corrupted) 320 | | C.Node branch_top -> 321 | Store.read_exn store index.C.bottom >>= fun branch_bottom -> 322 | match branch_bottom with 323 | | C.Index _ 324 | | C.Elt _ -> fail (Error `Corrupted) 325 | | C.Node branch_bottom -> 326 | let root = queue.root in 327 | let new_queue = {index; root} in 328 | apply from_top from_bottom new_queue branch_top 329 | branch_bottom new_node >>= fun node -> 330 | match old_node.C.previous with 331 | | None -> return new_node 332 | | Some old_previous -> ( 333 | Store.read_exn store old_previous >>= fun old_previous -> 334 | match old_previous with 335 | | C.Index _ 336 | | C.Elt _ -> fail (Error `Corrupted) 337 | | C.Node old_previous -> from_bottom queue old_previous node 338 | ) 339 | ) 340 | | None -> ( 341 | match old_node.C.previous with 342 | | None -> ( 343 | assert (C.equal_node old_node empty); 344 | return new_node; 345 | ) 346 | | Some old_previous -> ( 347 | Store.read_exn store old_previous >>= fun old_previous -> 348 | match old_previous with 349 | | C.Index _ 350 | | C.Elt _ -> fail (Error `Corrupted) 351 | | C.Node old_previous -> ( 352 | Store.add store (C.Node new_node) >>= fun key_node -> 353 | let new_previous = { 354 | C.next = Some key_node; 355 | C.previous = None; 356 | C.elt = old_node.C.elt; 357 | C.branch = None; 358 | } in from_bottom queue old_previous new_previous 359 | ) 360 | ) 361 | ) 362 | in 363 | 364 | Store.read_exn store index.C.top >>= fun top_node -> 365 | match top_node with 366 | | C.Index _ 367 | | C.Elt _ -> fail (Error `Corrupted) 368 | | C.Node top_node -> 369 | Store.read_exn store index.C.bottom >>= fun bottom_node -> 370 | match bottom_node with 371 | | C.Index _ 372 | | C.Elt _ -> fail (Error `Corrupted) 373 | | C.Node bottom_node -> 374 | apply from_top from_bottom q top_node bottom_node empty >>= fun node -> 375 | Store.add store (C.Node node) >>= fun key_top -> 376 | let index = { 377 | C.push = index.C.push; 378 | C.pop = index.C.pop; 379 | C.top = key_top; 380 | C.bottom = root; 381 | } in 382 | return { index; root } 383 | 384 | (* 385 | * Add a new node in the push list, and move the index on. 386 | * The new index is NOT added in the store, ie the queue is NOT updated. 387 | *) 388 | let push q elt = 389 | 390 | Store.create () >>= fun store -> 391 | let index = q.index in 392 | let root = q.root in 393 | 394 | Store.add store (C.Elt elt) >>= fun key_elt -> 395 | let node = { 396 | C.next = None; 397 | C.previous = Some index.C.bottom; 398 | C.elt = Some key_elt; 399 | C.branch = None; 400 | } in 401 | Store.add store (C.Node node) >>= fun key_node -> 402 | let index = { 403 | C.push = index.C.push + 1; 404 | C.pop = index.C.pop; 405 | C.top = index.C.top; 406 | C.bottom = key_node; 407 | } in 408 | return { index; root } 409 | 410 | let push_branch q branch = 411 | 412 | Store.create () >>= fun store -> 413 | let index = q.index in 414 | let root = q.root in 415 | 416 | let node = { 417 | C.next = None; 418 | C.previous = Some index.C.bottom; 419 | C.elt = None; 420 | C.branch = Some branch; 421 | } in 422 | Store.add store (C.Node node) >>= fun key_node -> 423 | let index = { 424 | C.push = index.C.push; 425 | C.pop = index.C.pop; 426 | C.top = index.C.top; 427 | C.bottom = key_node; 428 | } in 429 | return { index; root } 430 | 431 | (* 432 | * Move the index of the queue to the next element. 433 | * The new index is NOT added in the store, ie the queue is NOT updated. 434 | * Return None if the queue is empty. 435 | *) 436 | let rec pop q = 437 | 438 | Store.create () >>= fun store -> 439 | let index = q.index in 440 | let root = q.root in 441 | 442 | if index.C.push = index.C.pop then 443 | return None 444 | else 445 | Store.read_exn store index.C.top >>= fun node -> 446 | match node with 447 | | C.Index _ 448 | | C.Elt _ -> fail (Error `Corrupted) 449 | | C.Node node -> 450 | match node.C.elt with 451 | | None -> normalize q >>= fun q -> pop q 452 | | Some elt -> 453 | Store.read_exn store elt >>= fun elt -> 454 | match elt with 455 | | C.Index _ 456 | | C.Node _ -> fail (Error `Corrupted) 457 | | C.Elt elt -> 458 | let key = (match node.C.next with 459 | | None -> root 460 | | Some key -> key) in 461 | let index = { 462 | C.push = index.C.push; 463 | C.pop = index.C.pop + 1; 464 | C.top = key; 465 | C.bottom = index.C.bottom; 466 | } in 467 | 468 | return (Some (elt, { index; root })) 469 | 470 | (* 471 | * Move the index of the queue to the next element. 472 | * The new index is NOT added in the store, ie the queue is NOT updated. 473 | * Raise Empty if the queue is empty. 474 | *) 475 | let rec pop_exn q = 476 | 477 | Store.create () >>= fun store -> 478 | let index = q.index in 479 | let root = q.root in 480 | 481 | if index.C.push = index.C.pop then 482 | fail Empty 483 | else 484 | Store.read_exn store index.C.top >>= fun node -> 485 | match node with 486 | | C.Index _ 487 | | C.Elt _ -> fail (Error `Corrupted) 488 | | C.Node node -> 489 | match node.C.elt with 490 | | None -> normalize q >>= fun q -> pop_exn q 491 | | Some elt -> 492 | Store.read_exn store elt >>= fun elt -> 493 | match elt with 494 | | C.Index _ 495 | | C.Node _ -> fail (Error `Corrupted) 496 | | C.Elt elt -> 497 | let key = (match node.C.next with 498 | | None -> root 499 | | Some key -> key) in 500 | let index = { 501 | C.push = index.C.push; 502 | C.pop = index.C.pop + 1; 503 | C.top = key; 504 | C.bottom = index.C.bottom; 505 | } in 506 | 507 | return (elt, { index; root }) 508 | 509 | (* 510 | * Read the elt associated to the top node of the queue. 511 | * Return None if the queue is empty. 512 | *) 513 | let rec peek q = 514 | 515 | Store.create () >>= fun store -> 516 | let index = q.index in 517 | 518 | if index.C.push = index.C.pop then 519 | return None 520 | else 521 | Store.read_exn store index.C.top >>= fun node -> 522 | match node with 523 | | C.Index _ 524 | | C.Elt _ -> fail (Error `Corrupted) 525 | | C.Node node -> 526 | match node.C.elt with 527 | | None -> normalize q >>= fun q -> peek q 528 | | Some elt -> 529 | Store.read_exn store elt >>= fun elt -> 530 | match elt with 531 | | C.Index _ 532 | | C.Node _ -> fail (Error `Corrupted) 533 | | C.Elt elt -> 534 | return (Some (elt, q)) 535 | 536 | (* 537 | * Read the elt associated to the top node of the queue. 538 | * Raise Empty if the queue is empty. 539 | *) 540 | let rec peek_exn q = 541 | 542 | Store.create () >>= fun store -> 543 | let index = q.index in 544 | 545 | if index.C.push = index.C.pop then 546 | raise Empty 547 | else 548 | Store.read_exn store index.C.top >>= fun node -> 549 | match node with 550 | | C.Index _ 551 | | C.Elt _ -> fail (Error `Corrupted) 552 | | C.Node node -> 553 | match node.C.elt with 554 | | None -> normalize q >>= fun q -> peek_exn q 555 | | Some elt -> 556 | Store.read_exn store elt >>= fun elt -> 557 | match elt with 558 | | C.Index _ 559 | | C.Node _ -> fail (Error `Corrupted) 560 | | C.Elt elt -> 561 | return (elt, q) 562 | 563 | let dump q = 564 | 565 | Store.create () >>= fun store -> 566 | 567 | let rec from_top queue node = 568 | match node.C.next with 569 | | None -> ( 570 | match node.C.elt with 571 | | None -> return (Printf.sprintf (if C.equal_node node empty then "Empty%!" 572 | else "None%!")) 573 | | Some key -> 574 | Store.read_free store key >>= fun elt -> 575 | return (Printf.sprintf "Some %s%!" (C.to_string elt)) 576 | ) 577 | | Some next -> ( 578 | Store.read_free store next >>= fun next -> 579 | match next with 580 | | C.Index _ 581 | | C.Elt _ -> assert false 582 | | C.Node next -> ( 583 | from_top queue next >>= fun string -> 584 | match node.C.elt with 585 | | None ->return (Printf.sprintf "None -> %s%!" string) 586 | | Some elt -> 587 | Store.read_free store elt >>= fun elt -> 588 | return (Printf.sprintf "Some %s -> %s%!" (C.to_string elt) string) 589 | ) 590 | ) 591 | in 592 | 593 | let rec from_bottom queue node = 594 | match node.C.previous with 595 | | None -> ( 596 | match node.C.elt with 597 | | None -> return (Printf.sprintf (if C.equal_node node empty then "Empty%!" 598 | else "None%!")) 599 | | Some key -> 600 | Store.read_free store key >>= fun elt -> 601 | return (Printf.sprintf "Some %s%!" (C.to_string elt)) 602 | ) 603 | | Some previous -> ( 604 | Store.read_free store previous >>= fun previous -> 605 | match previous with 606 | | C.Index _ 607 | | C.Elt _ -> assert false 608 | | C.Node previous -> ( 609 | from_bottom queue previous >>= fun string -> 610 | match node.C.elt with 611 | | None ->return (Printf.sprintf "None -> %s%!" string) 612 | | Some elt -> 613 | Store.read_free store elt >>= fun elt -> 614 | return (Printf.sprintf "Some %s -> %s%!" (C.to_string elt) string) 615 | ) 616 | ) 617 | in 618 | 619 | Store.read_free store q.index.C.top >>= fun top -> 620 | match top with 621 | | C.Index _ 622 | | C.Elt _ -> assert false 623 | | C.Node top -> 624 | from_top q top >>= fun string_top -> 625 | Store.read_free store q.index.C.bottom >>= fun bottom -> 626 | match bottom with 627 | | C.Index _ 628 | | C.Elt _ -> assert false 629 | | C.Node bottom -> 630 | from_bottom q bottom >>= fun string_bottom -> 631 | let string = 632 | Printf.sprintf "push: %i, pop: %i\nfrom top: %s\nfrom bottom: %s\n\n%!" 633 | q.index.C.push q.index.C.pop string_top string_bottom; 634 | in return string 635 | 636 | let stats q = 637 | let ops = q.index.C.push + q.index.C.pop in 638 | let reads = get_read () in 639 | let writes = get_write () in 640 | { ops; reads; writes } 641 | 642 | let merge: Path.t -> t option Irmin.Merge.t = 643 | 644 | let rec clean old q = 645 | if old.index.C.push > q.index.C.pop 646 | && q.index.C.push > q.index.C.pop then 647 | pop_exn q >>= fun (_, q) -> clean old q 648 | else return q 649 | in 650 | 651 | let rec equalize old q1 q2 = 652 | if K.(q1.index.C.top = q2.index.C.top 653 | && q1.index.C.bottom = q2.index.C.bottom) 654 | then 655 | create () >>= fun q2 -> return (q1, q2) 656 | else ( 657 | if q2.index.C.pop > q1.index.C.pop 658 | && old.index.C.push > q1.index.C.pop 659 | && q1.index.C.push > q1.index.C.pop 660 | then 661 | pop_exn q1 >>= fun (_, q1) -> equalize old q1 q2 662 | else clean old q2 >>= fun q2 -> return (q1, q2)) 663 | in 664 | 665 | 666 | let merge ~old q1 q2 = 667 | old () >>= function (* FIXME *) 668 | | `Conflict _ | `Ok None -> conflict "merge" 669 | | `Ok (Some old) -> 670 | assert K.(q1.root = q2.root && old.root = q1.root); 671 | let root = q1.root in 672 | equalize old q1 q2 >>= fun (q1, q2) -> 673 | (if q2.index.C.push > q2.index.C.pop then 674 | push_branch q1 q2.index 675 | else return q1) >>= fun q -> 676 | let index = { 677 | C.push = q1.index.C.push + q2.index.C.push - old.index.C.push; 678 | C.pop = q1.index.C.pop + q2.index.C.pop - old.index.C.push; 679 | C.top = q.index.C.top; 680 | C.bottom = q.index.C.bottom; 681 | } in 682 | ok {index; root} 683 | in 684 | 685 | fun _path -> Irmin.Merge.option (module T) merge 686 | 687 | (* 688 | * Return all the keys (index, node or value) that are accessible. 689 | * Returned keys may be associated to unreadable value! 690 | * Should be only use by the GC. 691 | *) 692 | let list q list = 693 | 694 | Store.create () >>= fun store -> 695 | 696 | let add list = function 697 | | None -> list 698 | | Some opt -> opt :: list 699 | in 700 | 701 | let rec iter tmp_list res_list = match tmp_list with 702 | | [] -> return res_list 703 | | key :: tmp_list -> 704 | Store.read_exn store key >>= fun value -> 705 | match value with 706 | | C.Elt _ -> fail (Error `Invalid_access) 707 | | C.Index index -> iter 708 | (index.C.top :: index.C.bottom :: tmp_list) 709 | (index.C.top :: index.C.bottom ::res_list) 710 | | C.Node node -> 711 | let res_list = add res_list node.C.next in 712 | let res_list = add res_list node.C.previous in 713 | let res_list = add res_list node.C.elt in 714 | let tmp_list = add tmp_list node.C.next in 715 | let tmp_list = add tmp_list node.C.previous in 716 | match node.C.branch with 717 | | None -> iter tmp_list res_list 718 | | Some index -> iter 719 | (index.C.top :: index.C.bottom :: tmp_list) 720 | (index.C.top :: index.C.bottom ::res_list) 721 | in 722 | 723 | iter list (q.root::list) >>= fun list -> 724 | return (list_dedup list) 725 | 726 | end 727 | -------------------------------------------------------------------------------- /lib/merge_queue.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (c) 2014 Benjamin Farinier 3 | * Copyright (c) 2014 Thomas Gazagnaire 4 | * 5 | * Permission to use, copy, modify, and distribute this software for any 6 | * purpose with or without fee is hereby granted, provided that the above 7 | * copyright notice and this permission notice appear in all copies. 8 | * 9 | * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 10 | * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 11 | * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 12 | * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 13 | * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 14 | * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 15 | * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 16 | *) 17 | 18 | (** An efficient implementation of mergeable queues. *) 19 | 20 | type stats = { 21 | ops: int; 22 | reads : int; 23 | writes : int; 24 | } 25 | (** Statistic values. *) 26 | 27 | val string_of_stats: stats -> string 28 | (** Pretty-print the stats. *) 29 | 30 | exception Empty 31 | (** Empty queue. *) 32 | 33 | type error = [ `Corrupted | `Invalid_access ] 34 | (** Internal errors. *) 35 | 36 | exception Error of error 37 | (** Internal errors. *) 38 | 39 | module type S = sig 40 | 41 | include Irmin.Contents.S 42 | (** The type of queues. *) 43 | 44 | type elt 45 | (** The elements of the queues. *) 46 | 47 | val create : unit -> t Lwt.t 48 | (** Create a new queue. *) 49 | 50 | val length : t -> int Lwt.t 51 | (** Return the length of the queue [t]. *) 52 | 53 | val is_empty : t -> bool Lwt.t 54 | (** Return true if the given queue [t] is empty, false 55 | otherwise. *) 56 | 57 | val push : t -> elt -> t Lwt.t 58 | (** Returns a queue with adds [value] to the end of 59 | [t]. Complexity: O(1). *) 60 | 61 | val pop_exn : t -> (elt * t) Lwt.t 62 | (** Returns the top element and a version of the queue where it is 63 | removed. Raise [Empty] if the queue is empty. Complexity: 64 | amortized O(1). *) 65 | 66 | val pop : t -> (elt * t) option Lwt.t 67 | (** Like pop_exn, but returns result optionally, without 68 | exception. Complexity: amortized O(1). *) 69 | 70 | val peek_exn : t -> (elt * t) Lwt.t 71 | (** Returns the top element and a version of the queue updated but 72 | inchanged. Raises [Empty] if no element is found. Complexity: 73 | O(1). *) 74 | 75 | val peek : t -> (elt * t) option Lwt.t 76 | (** Like pop_exn, but returns result optionally, without 77 | exception. Complexity: O(1). *) 78 | 79 | val dump : t -> string Lwt.t 80 | (** Dump the contents of the queue. *) 81 | 82 | val stats : t -> stats 83 | (** Print global statistics on queue operations. *) 84 | 85 | end 86 | 87 | module type Config = sig 88 | val conf: Irmin.config 89 | val task: string -> Irmin.task 90 | end 91 | 92 | module Make 93 | (AO: Irmin.AO_MAKER) 94 | (K: Irmin.Hash.S) 95 | (V: Tc.S0) 96 | (P: Irmin.Path.S) 97 | (C: Config) 98 | : S with type elt = V.t 99 | and module Path = P 100 | --------------------------------------------------------------------------------