Stylelifecycle-ergonomics

7 files changed, 39 insertions, 52 deletions

diff --git a/lib/Logger.ml b/lib/Logger.ml
index ebb6c97..3355e23 100644
--- a/lib/Logger.ml
+++ b/lib/Logger.ml
@@ -1,5 +1,4 @@
 type level = Debug | Info | Warn | Error | Fatal
-
 type colors = Foreground | Blue | Yellow | Red | Purple
 
 let reset = "\027[0m"
@@ -13,10 +12,7 @@ let color_for = function
   | Purple -> "\027[35m"
 
 let colored color text = Printf.sprintf "%s%s%s%s" (color_for color) bold text reset
-
-let channel_for = function
-  | Warn | Error | Fatal -> stderr
-  | _ -> stdout
+let channel_for = function Warn | Error | Fatal -> stderr | _ -> stdout
 
 let prefix_for = function
   | Debug -> colored Foreground "[DEBUG]"
@@ -25,5 +21,4 @@ let prefix_for = function
   | Error -> colored Red "[ERROR]"
   | Fatal -> colored Purple "[FATAL]"
 
-let log level message =
-  Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
+let log level message = Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
index c7cc627..c7c0767 100644
--- a/lib/kernel/Namespace.ml
+++ b/lib/kernel/Namespace.ml
@@ -5,7 +5,6 @@ class namespace =
     method to_string = "namespace"
     val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = Atomic.make BatMap.empty
     method protocols = Protocols.[Directory.make self; Registry.make self]
-
     method destroy = Atomic.get entries |> BatMap.values |> BatEnum.iter Protocols.Handle.release
 
     method update key reference value =
@@ -13,11 +12,11 @@ class namespace =
         Utilities.Atomic.mswap entries (fun e ->
             let existing = BatMap.find_opt key e in
             if existing = reference then begin
-                Option.map Protocols.Handle.release existing |> ignore;
-                match value with
-                | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e)
-                | None -> Ok (BatMap.remove key e)
-              end
+              Option.map Protocols.Handle.release existing |> ignore;
+              match value with
+              | Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e)
+              | None -> Ok (BatMap.remove key e)
+            end
             else Error () )
       with
       | Ok _ -> Ok true
diff --git a/lib/kernel/Namespace.mli b/lib/kernel/Namespace.mli
index 9d4f343..394e44a 100644
--- a/lib/kernel/Namespace.mli
+++ b/lib/kernel/Namespace.mli
@@ -2,7 +2,6 @@ class namespace : object
   inherit Protocols.Handle.obj
   inherit Protocols.Directory.implementation
   inherit Protocols.Registry.implementation
-
   method destroy : unit
 end
 
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index a2e270e..2e712cc 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -23,8 +23,7 @@ let walking f g handle path =
   let open Protocols in
   let open Utilities.Result in
   let rec walk handle = function
-    | [] ->
-       g (Handle.keep handle)
+    | [] -> g (Handle.keep handle)
     | x :: xs -> (
         let* dir =
           Handle.require Directory.from handle
@@ -36,11 +35,10 @@ let walking f g handle path =
         | None -> Error (Error.path_not_found path)
         | Some elem -> f x handle (fun () -> walk elem xs) )
   in
-  Handle.with_autorelease
-    (fun () ->
+  Handle.with_autorelease (fun () ->
       walk handle path
       |> Result.map_error
-           Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))))
+           Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) )
 
 let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path
 
diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml
index 0f5f353..231f518 100644
--- a/lib/kernel/Session.ml
+++ b/lib/kernel/Session.ml
@@ -13,7 +13,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method pin state' = Atomic.set state state'
       method protocols = Protocols.[Directory.make self; Session.make self]
       method list = Ok (BatFingerTree.singleton "branch")
-
       method destroy = ()
 
       method find =
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index eea7db2..dd923c6 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -22,56 +22,54 @@ type t = {valid: bool Atomic.t; refers_to: obj; allocated_at: Printexc.raw_backt
 type 'a interface = {handle: t; interface: 'a}
 
 let object_of {valid; refers_to; _} =
-  if (Atomic.get valid) then refers_to else failwith "Attempt to dereference an invalid handle!"
+  if Atomic.get valid then refers_to else failwith "Attempt to dereference an invalid handle!"
 
-let to_string h = let o = (object_of h) in "#<" ^ o#to_string ^ " " ^ (Concepts.Hash.to_hum_string o#hash) ^ ">"
+let to_string h =
+  let o = object_of h in
+  "#<" ^ o#to_string ^ " " ^ Concepts.Hash.to_hum_string o#hash ^ ">"
 
 let invalidate {valid; _} = Atomic.compare_and_set valid true false
 
 let release handle =
   let o = object_of handle in
-  if invalidate handle then
-    o#release
+  if invalidate handle then o#release
 
 let on_gc ({valid; refers_to; allocated_at} as h) =
   (* TODO: get rid of this on release builds *)
-  if refers_to#is_managed && (Atomic.get valid) then begin
-      Logger.(log Warn ("Leaking handle to managed object " ^ (to_string h)));
-      Logger.(log Warn (BatString.nreplace
-                          (* bleh *)
-                          ~str:(Printexc.raw_backtrace_to_string allocated_at)
-                          ~sub:"Raised by primitive operation"
-                          ~by:"Allocated"));
-      release h
-    end
-
-type _ Effect.t += Autorelease: t -> unit Effect.t | Keep: t -> unit Effect.t
+  if refers_to#is_managed && Atomic.get valid then begin
+    Logger.(log Warn ("Leaking handle to managed object " ^ to_string h));
+    Logger.(
+      log Warn
+        (BatString.nreplace (* bleh *)
+           ~str:(Printexc.raw_backtrace_to_string allocated_at)
+           ~sub:"Raised by primitive operation" ~by:"Allocated" ) );
+    release h
+  end
+
+type _ Effect.t += Autorelease : t -> unit Effect.t | Keep : t -> unit Effect.t
 
 let with_autorelease f =
   let hs = Atomic.make BatSet.empty in
   Fun.protect
     ~finally:(fun () -> Atomic.get hs |> BatSet.iter release)
     (fun () ->
-      try f ()
-      with
-      | effect (Autorelease h), k ->
-         Utilities.Atomic.swap hs (fun ft -> BatSet.add h ft)
-         |> ignore;
-         Effect.Deep.continue k ()
-      | effect (Keep h), k ->
-         Utilities.Atomic.swap hs (fun ft -> BatSet.remove h ft)
-         |> ignore;
-         Effect.Deep.continue k ())
+      try f () with
+      | effect Autorelease h, k ->
+          Utilities.Atomic.swap hs (fun ft -> BatSet.add h ft) |> ignore;
+          Effect.Deep.continue k ()
+      | effect Keep h, k ->
+          Utilities.Atomic.swap hs (fun ft -> BatSet.remove h ft) |> ignore;
+          Effect.Deep.continue k () )
 
 let keep h = Effect.perform (Keep h); h
-
 let autorelease h = Effect.perform (Autorelease h); h
-
 let interface_of handle interface = {handle; interface}
+
 let make o =
-  let h = {valid= Atomic.make true; refers_to= (o :> obj); allocated_at= Printexc.get_callstack 256} in
-  Gc.finalise on_gc h;
-  h
+  let h =
+    {valid= Atomic.make true; refers_to= (o :> obj); allocated_at= Printexc.get_callstack 256}
+  in
+  Gc.finalise on_gc h; h
 
 let into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle)
 
@@ -93,5 +91,4 @@ let move handle =
 let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash
 let hash h = (object_of h)#hash
 let protocols h = (object_of h)#protocols
-
 let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
diff --git a/test/unit/kernel/Session.ml b/test/unit/kernel/Session.ml
index 1fe2b80..3ae549f 100644
--- a/test/unit/kernel/Session.ml
+++ b/test/unit/kernel/Session.ml
@@ -53,7 +53,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
 
   let suite =
     ( "kernel/session",
-      [ test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test") ] )
+      [test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test")] )
 end
 
 module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)