merge lifecycle-ergonomics and rework modes and contain checks

23 files changed, 238 insertions, 127 deletions

diff --git a/lib/Logger.ml b/lib/Logger.ml
new file mode 100644
index 0000000..3355e23
--- /dev/null
+++ b/lib/Logger.ml
@@ -0,0 +1,24 @@
+type level = Debug | Info | Warn | Error | Fatal
+type colors = Foreground | Blue | Yellow | Red | Purple
+
+let reset = "\027[0m"
+let bold = "\027[1m"
+
+let color_for = function
+  | Foreground -> "\027[39m"
+  | Blue -> "\027[34m"
+  | Yellow -> "\027[33m"
+  | Red -> "\027[31m"
+  | 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 prefix_for = function
+  | Debug -> colored Foreground "[DEBUG]"
+  | Info -> colored Blue "[INFO]"
+  | Warn -> colored Yellow "[WARN]"
+  | Error -> colored Red "[ERROR]"
+  | Fatal -> colored Purple "[FATAL]"
+
+let log level message = Printf.fprintf (channel_for level) "%s %s\n" (prefix_for level) message
diff --git a/lib/Logger.mli b/lib/Logger.mli
new file mode 100644
index 0000000..21d5b73
--- /dev/null
+++ b/lib/Logger.mli
@@ -0,0 +1,3 @@
+type level = Debug | Info | Warn | Error | Fatal
+
+val log : level -> string -> unit
diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml
index b7aa814..82c207f 100644
--- a/lib/concepts/Mode.ml
+++ b/lib/concepts/Mode.ml
@@ -1,30 +1,18 @@
-type attribute = string
 type attributes = BatSet.String.t
-type affordance = Decides | Generates of Cardinality.t
-type mode = {bound: attributes; affords: affordance}
+type mode = {bound: attributes; yields: Cardinality.t}
 type t = mode list
 
-let attributes_of_list = BatSet.String.of_list
-let attributes_of_map map = BatMap.String.keys map |> BatSet.String.of_enum
-let decides_when bound = {bound= attributes_of_list bound; affords= Decides}
-let enumerable cardinality = {bound= BatSet.String.empty; affords= Generates cardinality}
-let of_list modes = modes
+let mode bound yields = {bound= BatSet.String.of_list bound; yields}
 
-let generation declaration bound =
+let generation modes bound =
   List.fold_left
-    (fun tightest {bound= declared; affords} ->
-      match affords with
-      | Generates cardinality when BatSet.String.subset declared bound ->
-          Some (Option.fold ~none:cardinality ~some:(Cardinality.meet cardinality) tightest)
-      | Generates _ | Decides -> tightest )
-    None declaration
+    (fun tightest {bound= declared; yields} ->
+      if BatSet.String.subset declared bound then
+        Some (Option.fold ~none:yields ~some:(Cardinality.meet yields) tightest)
+      else tightest )
+    None modes
 
-let exhaustible declaration bound =
-  Option.fold ~none:false ~some:Cardinality.exhaustible (generation declaration bound)
+let exhaustible modes bound =
+  Option.fold ~none:false ~some:Cardinality.exhaustible (generation modes bound)
 
-let decision declaration bound =
-  exhaustible declaration bound
-  || List.exists
-       (fun {bound= declared; affords} ->
-         match affords with Decides -> BatSet.String.equal declared bound | Generates _ -> false )
-       declaration
+let project attributes = List.filter (fun {bound; _} -> BatSet.String.subset bound attributes)
diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli
index 6a906d1..d91b2ab 100644
--- a/lib/concepts/Mode.mli
+++ b/lib/concepts/Mode.mli
@@ -1,27 +1,14 @@
-type attribute = string
 type attributes = BatSet.String.t
 
-(** what asking a relation under a given set of bound attributes
-    affords. The answer is to whether anything satisfies the binding,
-    or the bindings of the attributes left free together with the
-    class of what is produced. *)
-type affordance = Decides | Generates of Cardinality.t
+(** given [bound], every matching tuple can be produced, and there are
+    at most [yields]. *)
+type mode = {bound: attributes; yields: Cardinality.t}
 
-type mode = {bound: attributes; affords: affordance}
-type t
+type t = mode list
 
-val attributes_of_list : attribute list -> attributes
-val attributes_of_map : 'a BatMap.String.t -> attributes
-val decides_when : attribute list -> mode
-val enumerable : Cardinality.t -> mode
-val of_list : mode list -> t
-
-(** the tightest class declared for generating under [bound]. A mode
-    declared for fewer bound attributes applies to more, since the
-    attributes left free are then fewer and no more numerous. *)
+val mode : string list -> Cardinality.t -> mode
 val generation : t -> attributes -> Cardinality.t option
-
 val exhaustible : t -> attributes -> bool
 
-(** declared outright, or implied by a generation that can be exhausted. *)
-val decision : t -> attributes -> bool
+(** the modes still usable when only [attributes] can be bound. *)
+val project : attributes -> t -> t
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 8f44818..9e204a9 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -121,6 +121,17 @@ let rec describe =
       | _ -> Error (Error.not_a_relation (Protocols.Handle.to_string relation)) )
   | Project (plan, attributes) -> describe plan |> fmap (restrict attributes)
 
+let rec modes =
+  let open Utilities.Result in
+  function
+  | Base relation ->
+      let* relation = Protocols.Relation.require relation in
+      Protocols.Relation.modes relation
+  | Project (plan, attributes) ->
+      modes plan
+      |> Result.map
+           (Concepts.Mode.project (BatSet.String.of_list (BatFingerTree.to_list attributes)))
+
 let enumerate relation =
   let open Utilities.Result in
   let* enumerable = Protocols.Enumerable.require relation in
@@ -154,24 +165,30 @@ let project description relation =
   in
   Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce)
 
-let derive relation description enumerate =
-  Kernel.EphemeralRelation.instantiate ~inputs:[relation] description
+let contains relation tuple =
+  Result.bind (Protocols.Relation.require relation) (fun r -> Protocols.Relation.contains r tuple)
+
+let derive ?decide relation description modes enumerate =
+  Kernel.EphemeralRelation.instantiate ~inputs:[relation] ?decide
+    ~modes:(fun () -> Ok modes)
+    description
     {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; program= None}
     (fun () -> enumerate relation)
 
 let rec execute plan =
   let open Utilities.Result in
   let* description = describe plan in
+  let* modes = modes plan in
   match plan with
   | Base relation ->
       let* relation =
         Protocols.Handle.copy relation
         |> Option.to_result ~none:(Error.released_relation (Protocols.Handle.to_string relation))
       in
-      Ok (derive relation description enumerate)
+      Ok (derive ~decide:(contains relation) relation description modes enumerate)
   | Project (plan, _) ->
       let* relation = execute plan in
-      Ok (derive relation description (project description))
+      Ok (derive relation description modes (project description))
 
 class evaluator =
   object (self)
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index ac8978b..25c2e7b 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -126,8 +126,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
               let* violations = Protocols.Admission.check admission in
               Ok
                 (List.map
-                   (fun (d, tuples) ->
-                     Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), tuples )
+                   (fun (d, witness) ->
+                     Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), witness )
                    violations ) )
         in
         Protocols.
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 206aae9..886d100 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -10,11 +10,8 @@ module Error = struct
   let refused violations =
     condition "refused" "The state is not admitted: a denial in it holds tuples"
       (List.fold_left
-         (fun ps (path, tuples) ->
-           ps
-           & path
-             |=| Concepts.Value.String
-                   (String.concat "; " (List.map Concepts.Tuple.to_string tuples)) )
+         (fun ps (path, witness) ->
+           ps & path |=| Concepts.Value.String (Concepts.Tuple.to_string witness) )
          empty violations )
 end
 
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 8cae91f..c0ec241 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -18,8 +18,12 @@ module Error = struct
 
   let unbound_program name =
     condition "unbound-program"
-      "A stored relation has to be instantiated by its evaluator before it can be enumerated"
+      "A relation generated by a program has to be given a state to run within before it is read"
       ("relation" |=| Concepts.Value.String name)
+
+  let undecidable_membership () =
+    condition "undecidable-membership"
+      "A relation with no membership test and no end was asked whether it holds a tuple" empty
 end
 
 module Persisted = struct
@@ -59,7 +63,7 @@ let persisted = function
       Some {Persisted.name; schematics; program}
   | _ -> None
 
-class ephemeral_relation ?program description value enumerate inputs =
+class ephemeral_relation ?program ?decide description value modes enumerate inputs =
   object (self)
     inherit Lifecycle.counted
     inherit Identity.of_id
@@ -67,19 +71,24 @@ class ephemeral_relation ?program description value enumerate inputs =
     val relation : t = value
     method destroy = List.iter Protocols.Handle.release inputs
     method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate ()
+    method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = modes ()
     method describe () = Ok (Protocols.Schematics.Relation description)
 
-    (* TODO: We do not need to scan, but simply apply a membership
-       criteria (set of constraints. For now this works, but it's
-       inneficient and hurts data independence, as there is an
-       assymetry between ephemeral and substantial relations. *)
     method contains (tuple : Concepts.Tuple.t) =
       let open Utilities.Result in
-      let* cursor = self#enumerate in
-      Protocols.Handle.releasing cursor (fun () ->
-          let* scan = Protocols.Cursor.require cursor in
-          Protocols.Cursor.exists scan (fun member ->
-              Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
+      match decide with
+      | Some decide -> decide tuple
+      | None ->
+          let* modes = self#modes in
+          if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then
+            Error (Error.undecidable_membership ())
+          else
+            let* cursor = self#enumerate in
+            Protocols.Handle.releasing cursor (fun () ->
+                let* scan = Protocols.Cursor.require cursor in
+                Protocols.Cursor.exists scan (fun member ->
+                    Concepts.Hash.hash_equals (Concepts.Tuple.hash member)
+                      (Concepts.Tuple.hash tuple) ) )
 
     method protocols : Protocols.Handle.protocol list =
       let protocols =
@@ -96,11 +105,13 @@ class ephemeral_relation ?program description value enumerate inputs =
           :: protocols
   end
 
-let instantiate ?(inputs = []) ?program description value enumerate =
-  new ephemeral_relation ?program description value enumerate inputs |> Protocols.Handle.make
+let instantiate ?(inputs = []) ?program ?decide ~modes description value enumerate =
+  new ephemeral_relation ?program ?decide description value modes enumerate inputs
+  |> Protocols.Handle.make
 
 let literal description tuples =
   instantiate description
+    ~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length tuples)))])
     {name= None; schematics= `Temporary description; program= None}
     (fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ())))
 
@@ -113,6 +124,7 @@ let enumerate_owned relation =
     object
       method reference = true
       method release = Protocols.Handle.release relation
+      method is_managed = true
     end
   in
   match
@@ -128,18 +140,29 @@ let enumerate_owned relation =
              method to_string = Protocols.Handle.to_string cursor
            end )
 
-let run name program within () =
-  let open Utilities.Result in
-  match program, within with
-  | Some program, Some within ->
-      let* executable = Protocols.Executable.require program in
-      Result.bind (Protocols.Executable.invoke executable [] ~within) enumerate_owned
-  | _ -> Error (Error.unbound_program name)
-
-let view ?within description program =
-  instantiate ~program description
+let asking f relation =
+  Protocols.Handle.releasing relation (fun () -> Result.bind (Protocols.Relation.require relation) f)
+
+(* What a program generates is known only from the relation it
+   returns, so reading it, asking its modes and asking for a tuple
+   all invoke it. *)
+let generated ?program ?within name description value =
+  let invoking f () =
+    let open Utilities.Result in
+    match program, within with
+    | Some program, Some within ->
+        let* executable = Protocols.Executable.require program in
+        Result.bind (Protocols.Executable.invoke executable [] ~within) f
+    | _ -> Error (Error.unbound_program name)
+  in
+  instantiate ?program
+    ~decide:(fun tuple -> invoking (asking (fun r -> Protocols.Relation.contains r tuple)) ())
+    ~modes:(invoking (asking Protocols.Relation.modes))
+    description value (invoking enumerate_owned)
+
+let of_program ?within description program =
+  generated ~program ?within (Protocols.Handle.to_string program) description
     {name= None; schematics= `Temporary description; program= None}
-    (run (Protocols.Handle.to_string program) (Some program) within)
 
 module Make (S : Abstract.Storage.STORAGE) = struct
   module SI = Storage.Make (S)
@@ -147,9 +170,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t)
       description =
-    instantiate ?program description
+    generated ?program ?within name description
       {name= Some name; schematics= `Persisted schematics; program= Some pointer}
-      (run name program within)
 
   let load ?bind connection (record : Persisted.t) =
     let open Utilities.Result in
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
index 272bb86..b83de3b 100644
--- a/lib/kernel/Generator.ml
+++ b/lib/kernel/Generator.ml
@@ -12,7 +12,7 @@ let resume k = Effect.Deep.continue k ()
 
 class producer_cursor produce finally =
   object (self)
-    inherit Lifecycle.null
+    inherit Lifecycle.counted
     inherit Identity.of_id
     method to_string = "producer-cursor"
     val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh
@@ -49,7 +49,7 @@ class producer_cursor produce finally =
       if limit <= 0 then Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= state = `Done}
       else fill 0 BatFingerTree.empty
 
-    method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> ()
+    method destroy = match state with `Fresh | `Live _ -> self#finish | `Done -> ()
   end
 
 let cursor_of ?finally produce = new producer_cursor produce finally |> Protocols.Handle.make
diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
index ac6bb20..4fb12b9 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -1,6 +1,7 @@
 class type lifecycle = object
   method reference : bool
   method release : unit
+  method is_managed : bool
 end
 
 class type virtual controlled_lifecycle = object
@@ -12,6 +13,7 @@ class null =
   object
     method reference = true
     method release = ()
+    method is_managed = false
   end
 
 class exclusive =
@@ -19,6 +21,7 @@ class exclusive =
     val taken = Atomic.make false
     method reference = Atomic.compare_and_set taken false true
     method release = Atomic.set taken false
+    method is_managed = true
   end
 
 class virtual counted =
@@ -27,6 +30,7 @@ class virtual counted =
     method virtual destroy : unit
     method reference = Atomic.incr references; true
     method release = if Atomic.fetch_and_add references (-1) = 1 then self#destroy
+    method is_managed = true
   end
 
 class retaining inner (owner : lifecycle) =
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index d4ef178..a323197 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -1,6 +1,7 @@
 class type lifecycle = object
   method reference : bool
   method release : unit
+  method is_managed : bool
 end
 
 class type virtual controlled_lifecycle = object
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index eaef8c3..f01a983 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -69,6 +69,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       condition "incomplete-multigroup"
         "A stored multigroup is missing part of its expected structure. Is your storage corrupted?"
         ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
+
+    let unjudgeable denial =
+      condition "unjudgeable-denial"
+        "A denial does not declare that reading it with nothing bound ends, so the state cannot \
+         be judged"
+        ("denial" |=| Concepts.Value.String denial)
   end
 
   module Representation = Concepts.Encoding.Record.Make (struct
@@ -177,16 +183,17 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   let held (name, relation) =
     let open Utilities.Result in
     Protocols.Handle.releasing relation (fun () ->
-        let* enumerable = Protocols.Enumerable.require relation in
-        let* cursor = Protocols.Enumerable.enumerate enumerable in
-        Protocols.Handle.releasing cursor (fun () ->
-            let* scan = Protocols.Cursor.require cursor in
-            let* first = Protocols.Cursor.next scan in
-            match first with
-            | None -> Ok []
-            | Some tuple ->
-                let* rest = Protocols.Cursor.drain scan () in
-                Ok [name, tuple :: BatFingerTree.to_list rest] ) )
+        let* denial = Protocols.Relation.require relation in
+        let* modes = Protocols.Relation.modes denial in
+        if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then
+          Error (Error.unjudgeable name)
+        else
+          let* enumerable = Protocols.Enumerable.require relation in
+          let* cursor = Protocols.Enumerable.enumerate enumerable in
+          Protocols.Handle.releasing cursor (fun () ->
+              let* scan = Protocols.Cursor.require cursor in
+              let* first = Protocols.Cursor.next scan in
+              Ok (Option.to_list (Option.map (fun witness -> name, witness) first)) ) )
 
   class multigroup ?bind conn value schema_tree denial_tree =
     object (self)
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
index 340e813..c7c0767 100644
--- a/lib/kernel/Namespace.ml
+++ b/lib/kernel/Namespace.ml
@@ -1,18 +1,22 @@
 class namespace =
   object (self)
-    inherit Lifecycle.null
+    inherit Lifecycle.counted
     inherit Identity.of_id
     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 =
       match
         Utilities.Atomic.mswap entries (fun e ->
-            if BatMap.find_opt key e = reference then
+            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 v e)
+              | 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 ec77724..394e44a 100644
--- a/lib/kernel/Namespace.mli
+++ b/lib/kernel/Namespace.mli
@@ -2,6 +2,7 @@ class namespace : object
   inherit Protocols.Handle.obj
   inherit Protocols.Directory.implementation
   inherit Protocols.Registry.implementation
+  method destroy : unit
 end
 
 val make : unit -> Protocols.Handle.t
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 4e36125..0814b1c 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -25,37 +25,33 @@ module Error = struct
 end
 
 let walking ?missing f g handle path =
+  let open Protocols in
+  let open Utilities.Result in
   let rec walk handle = function
-    | [] -> g handle
+    | [] -> g (Handle.keep handle)
     | x :: xs -> (
-        let open Utilities.Result in
-        let open Protocols in
         let* dir =
           Handle.require Directory.from handle
           |> Result.map_error
                Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x))
         in
-        let* elem = Directory.find dir x in
+        let* elem = Directory.find dir x |> Result.map (Option.map Handle.autorelease) in
         match elem with
         | None -> (
           match missing with Some m -> m () | None -> Error (Error.path_not_found path) )
         | Some elem -> f x handle (fun () -> walk elem xs) )
   in
-  walk handle path
-  |> Result.map_error
-       Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))
+  Handle.with_autorelease (fun () ->
+      walk handle path
+      |> Result.map_error
+           Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) )
 
-(* Handles we find in the middle of a walk get released once we're
-   done with them, but never the caller's root.  If you leak one and
-   its refcount never drops, nothing under that path gets collected,
-   and an exclusive object, like a session, stays locked forever. *)
-let releasing root handle f = if handle == root then f () else Protocols.Handle.releasing handle f
-let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path
+let lookup handle path = walking (fun _ _ f -> f ()) Result.ok handle path
 
 let find handle path =
   walking
     ~missing:(fun () -> Ok None)
-    (fun _ parent -> releasing handle parent)
+    (fun _ _ f -> f ())
     (fun h -> Ok (Some h))
     handle path
 
@@ -63,9 +59,8 @@ let update handle path key reference value =
   let open Utilities.Result in
   let open Protocols in
   let* target = lookup handle path in
-  releasing handle target (fun () ->
-      let* registry = Handle.require Registry.from target in
-      Registry.update registry key reference value )
+  let* registry = Handle.require Registry.from target in
+  Registry.update registry key reference value
 
 (* The changes at this object, and those beneath each child they reach. *)
 let split changes =
@@ -119,7 +114,7 @@ let assoc_all handle changes =
               | None when binds beneath -> Ok [x, Some (fresh beneath)]
               | None -> Ok []
               | Some child ->
-                  releasing handle child (fun () -> apply (prefix @ [x]) child beneath)
+                  Handle.releasing child (fun () -> apply (prefix @ [x]) child beneath)
                   |> Result.map (fun child' -> [x, Some child']) )
             below
           |> Utilities.List.sequence
diff --git a/lib/kernel/Session.ml b/lib/kernel/Session.ml
index 1abd278..231f518 100644
--- a/lib/kernel/Session.ml
+++ b/lib/kernel/Session.ml
@@ -4,7 +4,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   class session storage state =
     object (self)
-      inherit Lifecycle.exclusive
+      inherit Lifecycle.counted
       inherit Identity.of_id
       method to_string = "session"
       val storage : S.connection = storage
@@ -13,6 +13,7 @@ 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 =
         function
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 533893c..09aec90 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -116,6 +116,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct
             let* node = tuple_node tx relation in
             TupleSet.mem tx (Concepts.Tuple.hash tuple) node )
 
+      method modes =
+        Ok
+          Concepts.
+            [ Mode.mode [] Cardinality.Finite;
+              Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1)
+            ]
+
       method describe () = Ok (Protocols.Schematics.Relation description)
       method enumerate = enumerate connection relation
 
diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml
index 5a20105..c29f192 100644
--- a/lib/protocols/Admission.ml
+++ b/lib/protocols/Admission.ml
@@ -6,7 +6,7 @@ module Error = struct
       empty
 end
 
-type violations = (string * Concepts.Tuple.t list) list
+type violations = (string * Concepts.Tuple.t) list
 
 class type implementation = object
   method check : (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Admission.mli b/lib/protocols/Admission.mli
index 235eae7..7f0c596 100644
--- a/lib/protocols/Admission.mli
+++ b/lib/protocols/Admission.mli
@@ -1,5 +1,5 @@
 type t
-type violations = (string * Concepts.Tuple.t list) list
+type violations = (string * Concepts.Tuple.t) list
 
 class type implementation = object
   method check : (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index c8480a6..0c5f3cc 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -12,19 +12,65 @@ end
 class type obj = object
   method reference : bool
   method release : unit
+  method is_managed : bool
   method hash : Concepts.Hash.hash
   method to_string : string
   method protocols : protocol list
 end
 
-type t = {valid: bool ref; refers_to: obj}
+type t = {valid: bool Atomic.t; refers_to: obj; allocated_at: Printexc.raw_backtrace}
 type 'a interface = {handle: t; interface: 'a}
 
-let object_of {valid; refers_to} =
-  if !valid then refers_to else failwith "Attempt to dereference an invalid handle!"
+let object_of {valid; refers_to; _} =
+  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 invalidate {valid; _} = Atomic.compare_and_set valid true false
+
+let release handle =
+  let o = object_of handle in
+  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
+
+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 () )
+
+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 = {valid= ref true; refers_to= (o :> obj)}
+
+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 into handle f = List.find_map f (object_of handle)#protocols |> Option.map (interface_of handle)
 
 let invoke {handle; interface} f =
@@ -37,15 +83,13 @@ let copy handle =
   let o = object_of handle in
   if o#reference then Some (make o) else None
 
+let move handle =
+  let o = object_of handle in
+  invalidate handle |> ignore;
+  make o
+
 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 to_string h = (object_of h)#to_string
-
-let release ({valid; _} as handle) =
-  let o = object_of handle in
-  valid := false;
-  o#release
-
 let releasing handle f = Fun.protect ~finally:(fun () -> release handle) f
 let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index 5c74521..94734e4 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -5,6 +5,7 @@ type protocol = ..
 class type obj = object
   method reference : bool
   method release : unit
+  method is_managed : bool
   method hash : Concepts.Hash.hash
   method to_string : string
   method protocols : protocol list
@@ -15,6 +16,7 @@ val into : t -> (protocol -> 'a option) -> 'a interface option
 val from : 'a interface -> t
 val invoke : 'a interface -> ('a -> 'b) -> 'b
 val copy : t -> t option
+val move : t -> t
 val equal : t -> t -> bool
 val release : t -> unit
 val releasing : t -> (unit -> 'a) -> 'a
@@ -22,3 +24,6 @@ val hash : t -> Concepts.Hash.hash
 val protocols : t -> protocol list
 val to_string : t -> string
 val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result
+val with_autorelease : (unit -> 'a) -> 'a
+val autorelease : t -> t
+val keep : t -> t
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index af1201b..c1cdfee 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -8,6 +8,7 @@ end
 
 class type implementation = object
   method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+  method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
 end
 
 type Handle.protocol += Relation of implementation
@@ -17,6 +18,7 @@ let make impl = Relation (impl :> implementation)
 let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None)
 let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ())
 let contains i tuple = Handle.invoke i (fun o -> o#contains tuple)
+let modes i = Handle.invoke i (fun o -> o#modes)
 
 let heading relation =
   let open Utilities.Result in
diff --git a/lib/protocols/Relation.mli b/lib/protocols/Relation.mli
index 47d1d3e..28dfdff 100644
--- a/lib/protocols/Relation.mli
+++ b/lib/protocols/Relation.mli
@@ -2,12 +2,14 @@ type t
 
 class type implementation = object
   method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+  method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
 end
 
 val make : #implementation -> Handle.protocol
 val from : Handle.t -> t Handle.interface option
 val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
 val contains : t Handle.interface -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition) result
 
 (** the heading a relation describes itself with. *)
 val heading : Handle.t -> (Schematics.relation_description, Concepts.Condition.condition) result