rework store ephemeral relation under program and fail at path look

4 files changed, 72 insertions, 61 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 70e0711..ac8978b 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -108,7 +108,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
       method protocols : Protocols.Handle.protocol list =
         let bind =
-          Option.map (fun root -> Source.bind root ~within:(Protocols.Handle.make {<>})) root
+          Option.map
+            (fun root -> {EphemeralRelation.root; within= Protocols.Handle.make {<>}})
+            root
         in
         let multigroups =
           Prototype.mixture_of node (fun make node ->
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 7f1e79c..8cae91f 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -7,17 +7,6 @@ type t =
       | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ];
     program: program option }
 
-(* [name] is the relation a stored program defines, once it is read from
-   where it was stored under that name. *)
-type Protocols.Handle.protocol +=
-  | Stored of {evaluator: string; code: Concepts.Blob.t; name: string option}
-
-let stored handle =
-  Protocols.Handle.into handle (function
-    | Stored {evaluator; code; name} -> Some (evaluator, code, name)
-    | _ -> None )
-  |> Option.map (fun i -> Protocols.Handle.invoke i Fun.id)
-
 module Error = struct
   open Concepts.Condition
 
@@ -70,7 +59,7 @@ let persisted = function
       Some {Persisted.name; schematics; program}
   | _ -> None
 
-class ephemeral_relation ?code description value enumerate inputs =
+class ephemeral_relation ?program description value enumerate inputs =
   object (self)
     inherit Lifecycle.counted
     inherit Identity.of_id
@@ -93,34 +82,29 @@ class ephemeral_relation ?code description value enumerate inputs =
               Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
 
     method protocols : Protocols.Handle.protocol list =
-      let protocols = Protocols.[Relation.make self; Enumerable.make self; Schematics.make self] in
+      let protocols =
+        Protocols.[Relation.make self; Enumerable.make self; Schematics.make self]
+        @ Option.fold ~none:[] ~some:Protocols.Handle.protocols program
+      in
       match persisted relation with
       | None -> protocols
       | Some record ->
-          let stored =
-            Option.fold ~none:protocols
-              ~some:(fun code ->
-                Stored {evaluator= record.program.evaluator; code; name= Some record.name}
-                :: protocols )
-              code
-          in
           Protocols.Addressable.make
             object
               method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob
             end
-          :: stored
+          :: protocols
   end
 
-let instantiate ?(inputs = []) ?code description value enumerate =
-  new ephemeral_relation ?code description value enumerate inputs |> Protocols.Handle.make
+let instantiate ?(inputs = []) ?program description value enumerate =
+  new ephemeral_relation ?program description value enumerate inputs |> Protocols.Handle.make
 
 let literal description tuples =
   instantiate description
     {name= None; schematics= `Temporary description; program= None}
     (fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ())))
 
-type binding =
-  string -> Protocols.Handle.t -> (Protocols.Handle.t, Concepts.Condition.condition) result
+type binding = {root: Protocols.Handle.t; within: Protocols.Handle.t}
 
 (* The relation a program produced has to outlive the cursor over it. *)
 let enumerate_owned relation =
@@ -144,44 +128,55 @@ 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
+    {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)
   module R = SubstantialRelation.Make (S)
 
-  (* Unbound, a stored program is only its source. Bound, enumerating
-     it runs the program through its evaluator, afresh each time. *)
-  let restore ?bind ~code ({Persisted.name; schematics; program} : Persisted.t) description =
-    let enumerate () =
-      match bind with
-      | None -> Error (Error.unbound_program name)
-      | Some bind ->
-          let source =
-            Prototype.mixture [Stored {evaluator= program.evaluator; code; name= Some name}]
-          in
-          Result.bind (bind program.evaluator source) enumerate_owned
-    in
-    instantiate ~code description
-      {name= Some name; schematics= `Persisted schematics; program= Some program}
-      enumerate
+  let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t)
+      description =
+    instantiate ?program description
+      {name= Some name; schematics= `Persisted schematics; program= Some pointer}
+      (run name program within)
 
   let load ?bind connection (record : Persisted.t) =
-    SI.with_read connection (fun tx ->
-        let open Utilities.Result in
-        let* description = R.schema_of tx record.schematics in
-        let* code = SI.get_req tx (S.Hash record.program.code) in
-        Ok (restore ?bind ~code record description) )
+    let open Utilities.Result in
+    let* description, source =
+      SI.with_read connection (fun tx ->
+          let* description = R.schema_of tx record.schematics in
+          let* code = SI.get_req tx (S.Hash record.program.code) in
+          Ok (description, Bytes.to_string (Concepts.Blob.bytes_of_blob code)) )
+    in
+    match bind with
+    | None -> Ok (restore record description)
+    | Some {root; within} ->
+        let* program = Program.load root ~evaluator:record.program.evaluator ~source in
+        Ok (restore ~program ~within record description)
 
-  let store tx ~name ~evaluator ~code description =
+  let store tx ~name ~evaluator ~source description =
     let open Utilities.Result in
     let* schematics = R.store_schema tx description in
-    let* address = SI.store_blob tx code in
+    let* address = SI.store_blob tx (Concepts.Blob.blob_of_bytes (Bytes.of_string source)) in
     let record = {Persisted.name; schematics; program= {evaluator; code= address}} in
     let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in
     Ok record
 
-  let persist connection ~name ~evaluator ~code description =
+  let persist connection ~name program description =
+    let open Utilities.Result in
+    let* {Program.evaluator; source; _} = Program.require program in
     SI.with_transaction connection (fun tx ->
-        let open Utilities.Result in
-        let* record = store tx ~name ~evaluator ~code description in
-        Ok (restore ~code record description) )
+        let* record = store tx ~name ~evaluator ~source description in
+        Ok (restore ~program record description) )
 end
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 5a3390d..eaef8c3 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -31,12 +31,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let admit name h =
       let open Utilities.Result in
       let address entry = Concepts.Hash.hash_of_blob (encode entry) in
-      match EphemeralRelation.stored h with
-      | Some (evaluator, code, _) ->
+      match Program.image h with
+      | Some {evaluator; source; _} ->
           let* description = Protocols.Relation.heading h in
           Ok
             (fun tx ->
-              let* record = E.store tx ~name ~evaluator ~code description in
+              let* record = E.store tx ~name ~evaluator ~source description in
               Ok (address (Ephemeral record)) )
       | None ->
           let* description, tuples = Protocols.Relation.read h in
diff --git a/lib/kernel/Program.ml b/lib/kernel/Program.ml
index b528c5b..64a9fcf 100644
--- a/lib/kernel/Program.ml
+++ b/lib/kernel/Program.ml
@@ -17,6 +17,10 @@ module Error = struct
   let no_evaluator evaluator =
     condition "no-evaluator" "No evaluator is registered under that name"
       ("evaluator" |=| Concepts.Value.String evaluator)
+
+  let not_a_program name =
+    condition "not-a-program" "A handle was expected to carry a program and did not"
+      ("object" |=| Concepts.Value.String name)
 end
 
 type kind = Protocols.Evaluator.kind = ..
@@ -33,10 +37,17 @@ let reference evaluator =
   | Some i ->
       String.sub evaluator 0 i, String.sub evaluator (i + 1) (String.length evaluator - i - 1)
 
-let lookup root evaluator =
+let require handle =
+  image handle |> Option.to_result ~none:(Error.not_a_program (Protocols.Handle.to_string handle))
+
+let with_evaluator root evaluator f =
+  let open Utilities.Result in
   let scope, language = reference evaluator in
-  Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this)
-  |> Result.map_error (fun _ -> Error.no_evaluator evaluator)
+  let* found =
+    Path.lookup root Path.(scope @/ "evaluator" @/ language @/ this)
+    |> Result.map_error (fun _ -> Error.no_evaluator evaluator)
+  in
+  Protocols.Handle.releasing found (fun () -> Result.bind (Protocols.Evaluator.require found) f)
 
 class program ?root image =
   object (self)
@@ -47,9 +58,7 @@ class program ?root image =
     method invoke inputs ~within =
       let open Utilities.Result in
       let* root = Option.to_result ~none:(Error.unloaded image.evaluator) root in
-      let* found = lookup root image.evaluator in
-      Protocols.Handle.releasing found (fun () ->
-          let* evaluator = Protocols.Evaluator.require found in
+      with_evaluator root image.evaluator (fun evaluator ->
           Protocols.Evaluator.eval evaluator image.kind inputs ~within )
 
     method protocols : Protocols.Handle.protocol list =
@@ -58,3 +67,8 @@ class program ?root image =
 
 let make ?root ~evaluator ~source kind =
   new program ?root {evaluator; kind; source} |> Protocols.Handle.make
+
+let load root ~evaluator ~source =
+  with_evaluator root evaluator (fun found ->
+      Protocols.Evaluator.parse found source
+      |> Result.map (make ~root ~evaluator ~source) )