refactor ephemeral and subs relations

7 files changed, 70 insertions, 79 deletions

diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml
index 23abacf..6ac1704 100644
--- a/lib/concepts/Mode.ml
+++ b/lib/concepts/Mode.ml
@@ -21,15 +21,16 @@ let generation declaration bound =
     (fun tightest {bound= declared; affords} ->
       match affords with
       | Generates cardinality when BatSet.String.subset declared bound ->
-          Some
-            ( match tightest with
-            | None -> cardinality
-            | Some other -> Cardinality.meet cardinality other )
+          Some (Option.fold ~none:cardinality ~some:(Cardinality.meet cardinality) tightest)
       | Generates _ | Decides -> tightest )
     None declaration
 
+let exhaustible declaration bound =
+  Option.fold ~none:false ~some:Cardinality.exhaustible (generation declaration bound)
+
 let decision declaration bound =
-  List.exists
-    (fun {bound= declared; affords} ->
-      match affords with Decides -> BatSet.String.equal declared bound | Generates _ -> false )
-    declaration
+  exhaustible declaration bound
+  || List.exists
+       (fun {bound= declared; affords} ->
+         match affords with Decides -> BatSet.String.equal declared bound | Generates _ -> false )
+       declaration
diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli
index 982518a..8d84093 100644
--- a/lib/concepts/Mode.mli
+++ b/lib/concepts/Mode.mli
@@ -24,4 +24,7 @@ val to_list : t -> mode list
     attributes left free are then fewer and no more numerous. *)
 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
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 4947869..29b15ed 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -42,14 +42,6 @@ module Make (D : DERIVATION) = struct
         |> Bytes.of_string
         |> Concepts.Hash.hash_of_bytes
 
-  let exhaustible declaration bound =
-    match Concepts.Mode.generation declaration bound with
-    | Some cardinality -> Concepts.Cardinality.exhaustible cardinality
-    | None -> false
-
-  let decides declaration bound =
-    Concepts.Mode.decision declaration bound || exhaustible declaration bound
-
   (* A cursor holds a reference to its relation, so the edges it reads
      outlive a release of the relation that produced it. *)
   class retaining scan release_owner =
@@ -65,16 +57,16 @@ module Make (D : DERIVATION) = struct
       method protocols : Protocols.Handle.protocol list = [Protocols.Cursor.make self]
     end
 
-  class ephemeral plan address declaration total edges =
+  class ephemeral (plan : D.plan) address declaration description edges =
     object (self)
       inherit Lifecycle.counted
-      val plan : D.plan = plan
+      val heading = BatMap.String.keys description |> BatSet.String.of_enum
       method destroy = List.iter Protocols.Handle.release edges
       method predicate = Ok None
       method local_constraints = Ok None
       method modes = Ok declaration
 
-      method private retained binding =
+      method generate binding =
         let open Utilities.Result in
         let bound = Protocols.Generative.bound binding in
         let* () =
@@ -90,11 +82,8 @@ module Make (D : DERIVATION) = struct
             ignore self#reference;
             Ok (new retaining scan (fun () -> self#release) |> Protocols.Handle.make)
 
-      method generate binding = self#retained binding
-      method enumerate = self#retained Protocols.Generative.nothing
-
-      method describe () =
-        D.describe plan |> Result.map (fun description -> Protocols.Schematics.Relation description)
+      method enumerate = self#generate Protocols.Generative.nothing
+      method describe () = Ok (Protocols.Schematics.Relation description)
 
       (* Membership of a derived relation is decided by the derivation
          and not by a lookup, so it is asked of the generator under the
@@ -104,11 +93,11 @@ module Make (D : DERIVATION) = struct
         let open Utilities.Result in
         let binding = tuple.Concepts.Tuple.attributes in
         let bound = Protocols.Generative.bound binding in
-        let* description = D.describe plan in
-        let described = BatMap.String.keys description |> BatSet.String.of_enum in
-        if not (BatSet.String.equal described bound) then Ok false
+        if not (BatSet.String.equal heading bound) then Ok false
         else
-          let* () = if decides declaration bound then Ok () else Error (Error.undecidable bound) in
+          let* () =
+            if Concepts.Mode.decision declaration bound then Ok () else Error (Error.undecidable bound)
+          in
           let* cursor = D.generate plan binding in
           let expected = Concepts.Tuple.hash tuple in
           Fun.protect
@@ -131,17 +120,22 @@ module Make (D : DERIVATION) = struct
             Protocols.Schematics.make self;
             Protocols.Generative.make self ]
         in
-        if total then Protocols.Enumerable.make self :: carried else carried
+        if Concepts.Mode.exhaustible declaration BatSet.String.empty then
+          Protocols.Enumerable.make self :: carried
+        else carried
 
       method hash : Concepts.Hash.hash = address
     end
 
   let derive ?pinned ?(edges = []) plan =
     let open Utilities.Result in
-    let* declaration =
-      D.modes plan |> Result.map_error (fun c -> List.iter Protocols.Handle.release edges; c)
+    let derived =
+      let* declaration = D.modes plan in
+      let* description = D.describe plan in
+      Ok
+        ( new ephemeral plan (identity ?pinned plan) declaration description edges
+        |> Protocols.Handle.make )
     in
-    Ok
-      ( new ephemeral plan (identity ?pinned plan) declaration (exhaustible declaration BatSet.String.empty) edges
-      |> Protocols.Handle.make )
+    Result.iter_error (fun _ -> List.iter Protocols.Handle.release edges) derived;
+    derived
 end
diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml
index f9aafb0..b8f4962 100644
--- a/lib/kernel/Generator.ml
+++ b/lib/kernel/Generator.ml
@@ -10,20 +10,25 @@ let start produce =
 
 let resume k = Effect.Deep.continue k ()
 
-class producer_cursor produce on_release =
+class producer_cursor produce finally =
   object (self)
     inherit Lifecycle.null
     inherit Identity.of_id
 
     val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh
     method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self]
+
+    method private finish =
+      state <- `Done;
+      Option.iter (fun f -> f ()) finally
+
     method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result =
       let settle = function
         | Element (tuple, k) ->
             state <- `Live k;
             Ok (Some tuple)
         | Finished r ->
-            state <- `Done;
+            self#finish;
             Result.map (fun () -> None) r
       in
       match state with
@@ -45,12 +50,8 @@ class producer_cursor produce on_release =
         Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)}
       else fill 0 BatFingerTree.empty
 
-    method! release =
-      (match state with
-       | `Fresh | `Live _ -> Option.iter (fun f -> f ()) on_release
-       | `Done -> ());
-      state <- `Done
+    method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> ()
   end
 
-let cursor_of ?on_release produce =
-  new producer_cursor produce on_release |> Protocols.Handle.make
+let cursor_of ?finally produce =
+  new producer_cursor produce finally |> Protocols.Handle.make
diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml
index dd06783..f0c4800 100644
--- a/lib/kernel/Storage.ml
+++ b/lib/kernel/Storage.ml
@@ -36,11 +36,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
        let _ = S.abort tx in
        Error condition
 
-  let with_transaction connection body =
+  let within start connection body =
     let open Utilities.Result in
-    let* tx = S.start connection in
+    let* tx = start connection in
     body tx |> finish tx
 
+  let with_transaction connection = within S.start connection
+  let with_read connection = within S.start_read connection
+
   let store_blob tx blob =
     let open Utilities.Result in
     let address = Concepts.Hash.hash_of_blob blob in
diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli
index b8c0e5b..fa8a785 100644
--- a/lib/kernel/Storage.mli
+++ b/lib/kernel/Storage.mli
@@ -12,6 +12,7 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig
 
   val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result
   val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result
+  val with_read : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result
   val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result
   val get_req: S.transaction -> S.address -> (Concepts.Blob.t, Concepts.Condition.condition) result
 end
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 388d510..7beb133 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -123,46 +123,38 @@ module Make (S : Abstract.Storage.STORAGE) = struct
            |> Result.map (fun domain ->
                   (name, {Protocols.Schematics.domain; provenance= []}) ) )
     |> Utilities.List.sequence
-    |> Result.map (fun kvs ->
-           List.fold_left
-             (fun acc (name, attribute) -> BatMap.String.add name attribute acc)
-             BatMap.String.empty kvs)
+    |> Result.map BatMap.String.of_list
 
-  let scan storage relation ~keep =
+  let generate storage relation binding =
     let open Utilities.Result in
     let* tx = S.start_read storage in
-    let closed = ref false in
-    let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in
+    let close () = ignore (S.abort tx) in
     let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in
     (* The fold is suspended by [yield], so the tree is walked one node
        and one tuple at a time rather than materialized before the
        first tuple is produced. *)
     let produce ~yield =
-      let walked = TupleSet.iter tx (fun _ tuple -> if keep tuple then yield tuple) node in
-      close ();
-      walked
+      TupleSet.iter tx
+        (fun _ tuple -> if Protocols.Generative.satisfies binding tuple then yield tuple)
+        node
     in
-    Ok (Generator.cursor_of ~on_release:close produce)
+    Ok (Generator.cursor_of ~finally:close produce)
 
-  let enumerate storage relation = scan storage relation ~keep:(fun _ -> true)
+  let enumerate storage relation = generate storage relation Protocols.Generative.nothing
 
-  let generate storage relation binding =
-    scan storage relation ~keep:(Protocols.Generative.satisfies binding)
+  let modes_of description =
+    Concepts.Mode.of_list
+      [ Concepts.Mode.enumerable Concepts.Cardinality.Finite;
+        Concepts.Mode.decides_when (BatMap.String.keys description |> BatList.of_enum) ]
 
-  let modes tx relation =
-    let open Utilities.Result in
-    let* description = schema_of tx relation in
-    let labels = BatMap.String.keys description |> BatList.of_enum in
-    Ok
-      (Concepts.Mode.of_list
-         [ Concepts.Mode.enumerable Concepts.Cardinality.Finite;
-           Concepts.Mode.decides_when labels ] )
-
-  class relation storage value declaration =
+  let modes tx relation = schema_of tx relation |> Result.map modes_of
+
+  class relation storage value description =
     object (self)
       inherit Lifecycle.null
       val storage : S.connection = storage
       val relation : t = value
+      val declaration = modes_of description
       method predicate = Ok relation.predicate
       method local_constraints = Ok relation.local_constraints
 
@@ -171,10 +163,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method contains (tuple : Concepts.Tuple.t) =
         SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple)
 
-      method describe () =
-        let open Utilities.Result in
-        let* description = SI.with_transaction storage (fun tx -> schema_of tx relation) in
-        Ok (Protocols.Schematics.Relation description)
+      method describe () = Ok (Protocols.Schematics.Relation description)
 
       (* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as
          [Relation]. A procedural relation would carry only the latter, which is how an evaluator
@@ -194,12 +183,11 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       method hash = hash relation
     end
 
-  (* Modes follow from the schema alone, which a relation never changes,
-     so they are read once here rather than on every request. *)
+  (* A relation never changes its schema, so it is read once here and
+     the description and modes are served from it on every request. *)
   let instantiate tx conn relation =
-    let open Utilities.Result in
-    let* declaration = modes tx relation in
-    Ok (new relation conn relation declaration |> Protocols.Handle.make)
+    schema_of tx relation
+    |> Result.map (fun description -> new relation conn relation description |> Protocols.Handle.make)
 
   let make conn ~schematics ?predicate ?local_constraints ?indexes () =
     let open Utilities.Result in
@@ -213,7 +201,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let* data = SI.get_req tx (S.Hash addr) in
     Representation.of_blob data
 
-  let wrap conn relation = SI.with_transaction conn (fun tx -> instantiate tx conn relation)
+  let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation)
 
   let load tx conn addr =
     load_value tx addr |> Utilities.Result.fmap (instantiate tx conn)