Revive

src/_tags

@@ -2,10 +2,10 @@ true: annot
 true: debug
 true: package(lwt)
 true: package(lwt.unix)
-true: package(lwt.preemptive)
-<**/*.ml>: warn_error_A
+
+<**/*.ml>: warn_A
 <**/*_test.ml>: -warn_error_A, warn_A
-<flog*.ml>: warn_error_A
+<flog*.ml>: warn_A
 <flog0.o>: use_libbaardskeerder
 <test.*>: package(oUnit), use_libbaardskeerder
 <*_test.*>: package(oUnit), package(quickcheck)

src/baardskeerder.mli

@@ -25,8 +25,6 @@ type action =
   | Set of k * v
   | Delete of k
 
-type ('a,'b) result = | OK of 'a | NOK of 'b
-
 val init : string -> unit
 val make : string -> t
 val close : t -> unit

src/base.ml

@@ -32,10 +32,6 @@ type action =
   |Delete of k
 
 
-type ('a,'b) result =
-  | OK of 'a
-  | NOK of 'b
-
 type kp = k * pos
 
 let kpl2s l =

src/base_test.ml

@@ -1,3 +1,3 @@
 let ok_or_fail = function
-  | Base.OK () -> Mlog.return ()
-  | Base.NOK _ -> failwith "NOK"
+  | Ok () -> Mlog.return ()
+  | Error _ -> failwith "Error"

src/binary.ml

@@ -39,8 +39,8 @@ let run_writer ?buffer_size:(bs=64): ('a writer) -> 'a -> (string * int) =
 
 let ord = Char.code
 and uchr = Char.unsafe_chr
-and uget = String.unsafe_get
-and uset = String.unsafe_set
+and uget = Bytes.unsafe_get
+and uset = Bytes.unsafe_set
 
 let check l s o =
   if not (o >= 0 && o <= String.length s - l)

src/bsmgr.ml

@@ -17,10 +17,8 @@
  * along with Baardskeerder.  If not, see <http://www.gnu.org/licenses/>.
  *)
 
-open Unix
 open Tree
 open Arg
-open Log
 open Dbx
 open Sync
 
@@ -56,7 +54,7 @@ let get_store = function
   | _ -> invalid_arg "get_store"
 
 let () =
-  let command = ref Help in
+  let command = ref (Help:command) in
 
   let dump () = command := Dump in
   let dump_stream () = command := DumpStream in
@@ -139,7 +137,7 @@ let () =
       then return ()
       else
         let key = make_key i in
-        get key >>= fun v ->
+        get key >>= fun _v ->
         loop (i+1)
     in
     loop 0
@@ -154,8 +152,8 @@ let () =
       else
         let key = make_key i in
         delete key >>= function
-        | Base.OK () -> loop (i+1)
-        | Base.NOK k -> failwith (Printf.sprintf "%s not found" k)
+        | Ok () -> loop (i+1)
+        | Error k -> failwith (Printf.sprintf "%s not found" k)
     in
     loop 0
   in
@@ -167,7 +165,7 @@ let () =
         let rec loop i =
           let kn = b+ i in
           if i = m || kn >= n
-          then return (Base.OK ())
+          then return (Ok ())
           else
             let k = make_key kn in
             MyDBX.set tx k v >>= fun () ->
@@ -183,8 +181,8 @@ let () =
       then MyLog.sync db
       else
         set_tx i >>= function
-        | Base.OK () -> loop (i+m)
-        | Base.NOK k -> failwith (Printf.sprintf "NOK %s" k)
+        | Ok ()   -> loop (i+m)
+        | Error k -> failwith (Printf.sprintf "Error %s" k)
     in
     loop 0
   in
@@ -255,7 +253,7 @@ let () =
           let module MyRewrite = Rewrite.Rewrite(MyF)(MyF)(MyStore) in
           MyLog.make !fn >>= fun l0 ->
           let now0 = MyLog.now l0 in
-          let (x0,y0,g0) = now0 in
+          let (x0,y0,_g0) = now0 in
           let now0' = Time.make x0 y0 true in
           MyLog.init !fn2 now0' >>= fun () ->
           MyLog.make !fn2 >>= fun l1 ->

src/catchup.ml

@@ -10,19 +10,12 @@ module Catchup(L: LOG) = struct
   let (>>=) = L.bind
 
   let read_value log pos =
-    (L.read log pos) >>= (function
-      | Value v -> L.return v
-      | e -> failwith (Printf.sprintf "Catchup:%s is not a value" (entry2s e))
-     )
+    L.read log pos >>= fun e ->
+    L.return (get_value e)
 
   let read_commit log pos =
-    L.bind
-      (L.read log pos)
-      (function
-        | Commit c -> L.return c
-        | e -> failwith (Printf.sprintf "Catchup:%s is not commit" (entry2s e))
-      )
-
+    L.read log pos >>= fun e ->
+    L.return (get_commit e)
 
   let translate_caction log = function
     | CSet (k,vp) -> read_value log vp >>= fun v -> L.return (Set (k,v))
@@ -42,21 +35,20 @@ module Catchup(L: LOG) = struct
   let catchup (i0: int64) (f : 'a -> int64 -> action list -> 'a L.m) (a0:'a) (log : L.t) =
     let start = (i0, 0,false) in
     let rec go_back acc p =
-      L.bind
-        (L.read log p)
-        (function
-          | Commit c ->
-              let t0 = Commit.get_time c in
-              if t0 =>: start
-              then
-                let p' = Commit.get_previous c in
-                go_back (p::acc) p'
-              else
-                L.return acc
-          | NIL ->
-              L.return acc
-          | e -> failwith (Printf.sprintf "Catchup:%s is not commit" (entry2s e))
-        )
+      L.read log p >>= 
+      function
+      | Commit c ->
+         let t0 = Commit.get_time c in
+         if t0 =>: start
+         then
+           let p' = Commit.get_previous c in
+           go_back (p::acc) p'
+         else
+           L.return acc
+      | NIL ->
+         L.return acc
+      | Value _ | Leaf _ | Index _ as e -> Entry.wrong "commit|nil" e
+
     in
     go_back [] (L.last log) >>= fun ps ->
     match ps with

src/catchup_test.ml

@@ -8,11 +8,11 @@ module MDBX = DBX(Mlog)
 
 let (>>=) = Mlog.bind
 
-let ok_set tx ki vi = MDBX.set tx ki vi >>= fun () -> return (Base.OK ())
+let ok_set tx ki vi = MDBX.set tx ki vi >>= fun () -> return (Ok ())
 
 let ok_unit x = match x with
-  | Base.OK () -> Mlog.return ()
-  | Base.NOK _ -> failwith "should not happen"
+  | Ok () -> Mlog.return ()
+  | Error _ -> failwith "should not happen"
 
 let catchup1 () =
   let fn = "mlog" in

src/dbx.ml

@@ -21,7 +21,6 @@ open Base
 open Tree
 open Log
 open Entry
-open Slab
 open Commit
 open Catchup
 open Prefix
@@ -50,11 +49,11 @@ module DBX(L:LOG) = struct
   let delete tx k =
     DBL._delete tx.log tx.slab k >>= fun r ->
     let r' = match r with
-      | OK _ ->
+      | Ok _ ->
           let a = CDelete k in
           let () = tx.cactions <- a :: tx.cactions in
-          OK ()
-      | NOK k -> NOK k
+          Ok ()
+      | Error k -> Error k
     in
     return r'
 
@@ -66,7 +65,7 @@ module DBX(L:LOG) = struct
     let tx = {log;slab;cactions = []} in
     f tx >>= fun txr ->
     match txr with
-      | OK a ->
+      | Ok _a ->
           let root = Slab.length tx.slab -1 in
           let previous = L.last log in
           let pos = Inner root in
@@ -78,7 +77,7 @@ module DBX(L:LOG) = struct
           let slab' = Slab.compact tx.slab in
           L.write log slab' >>= fun () ->
           return txr
-      | NOK k -> return txr
+      | Error _k -> return txr
 
 
 
@@ -94,15 +93,15 @@ module DBX(L:LOG) = struct
   let prefix_keys (tx:tx) (prefix : string) (max: int option) =
     PrL.prefix_keys tx.log tx.slab prefix max
 
-  let multi_delete (tx:tx) (keys: k list) : (int,k) Base.result L.m =
+  let multi_delete (tx:tx) (keys: k list) : (int,k) result L.m =
     let rec _inner (acc:int) keys = match keys with
-      | [] -> let r = OK acc in
+      | [] -> let r = Ok acc in
               return r
       | k :: keys ->
           begin
             delete tx k >>= function
-              | OK r   -> _inner (acc+1) keys
-              | NOK k  -> return (NOK k)
+              | Ok _r   -> _inner (acc+1) keys
+              | Error k  -> return (Error k)
           end
     in _inner 0 keys
 
@@ -111,19 +110,19 @@ module DBX(L:LOG) = struct
     let rec _inner tx acc : (int,Base.k) result L.m =
       prefix_keys tx prefix max >>= fun keys ->
       match keys with
-        | []   -> return (OK acc)
+        | []   -> return (Ok acc)
         | keys ->
             begin
               multi_delete tx keys >>= fun r ->
               match r with
-                | OK i ->
+                | Ok i ->
                     _inner tx (acc + i)
-                | r -> return r
+                | Error _ -> return r
             end
     in
     _inner tx 0 >>= function
-      | OK i -> return i
-      | NOK k -> failwith (Printf.sprintf "delete_prefix: %s" k)
+      | Ok i -> return i
+      | Error k -> failwith (Printf.sprintf "delete_prefix: %s" k)
 
   let log_update (log:L.t) ?(diff = true) (f: tx -> ('a,'b) result L.m) =
     let previous = L.last log in
@@ -135,7 +134,7 @@ module DBX(L:LOG) = struct
               else Commit.get_lookup lc
             in return lu
         | NIL -> return previous
-        | e -> failwith (Printf.sprintf "log_update: %s is not commit" (entry2s e))
+        | Value _ | Index _ | Leaf _ as e -> wrong "Commit|Nil" e
     in
     let now = L.now log in
     let fut = if diff then Time.next_major now else now in
@@ -145,7 +144,7 @@ module DBX(L:LOG) = struct
 
     _find_lookup () >>= fun lookup ->
     f tx >>= function
-      | OK x ->
+      | Ok x ->
           begin
             let sl = Slab.length tx.slab in
             if sl > 0
@@ -158,15 +157,15 @@ module DBX(L:LOG) = struct
                 let _ = Slab.add tx.slab c in
                 let slab' = Slab.compact tx.slab in
                 L.write log slab' >>= fun () ->
-                return (OK x)
+                return (Ok x)
               end
             else (* This is an empty transaction *)
               begin
                 L.read log previous >>=
                   begin function
                     | Commit lc -> return (Commit.get_pos lc)
                     | NIL       -> return (Inner (-1))
-                    | e -> failwith (Printf.sprintf "log_update %s is not a commit" (entry2s e))
+                    | Value _ | Leaf _ | Index _ as e -> wrong "commit|nil" e
                   end
                 >>= fun ppos ->
                 let commit = make_commit
@@ -180,16 +179,16 @@ module DBX(L:LOG) = struct
                 let _ = Slab.add tx.slab c in
                 let slab' = Slab.compact tx.slab in
                 L.write log slab' >>= fun () ->
-                return (OK x)
+                return (Ok x)
               end
           end
-      | NOK k -> return (NOK k)
+      | Error k -> return (Error k)
 
   let commit_last (log:L.t) =
     let pp = L.last log in
-    (L.read log pp >>= function
-      | Commit lc -> L.return lc
-      | e -> failwith (Printf.sprintf "_read_commit: %s is not commit" (entry2s e))
+    (L.read log pp >>= fun entry ->
+     let lc = get_commit entry in
+     L.return lc
     ) >>= fun lc ->
     let time = Commit.get_time lc in
     let slab = Slab.make time in
@@ -214,6 +213,6 @@ module DBX(L:LOG) = struct
           CaL.translate_cactions log cas >>= fun actions ->
           L.return (Some (i, actions, explicit))
       | NIL -> L.return None
-      | e -> failwith (Printf.sprintf "last_update: %s should be commit" (entry2s e))
+      | Value _ | Index _ | Leaf _ as e -> wrong "commit|nil" e
 
 end