rework evaluators and add schema scope

1 files changed, 68 insertions, 53 deletions

diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index ecc871e..4530004 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -1,37 +1,12 @@
 module Make (S : Abstract.Storage.STORAGE) = struct
   module SI = Storage.Make (S)
-  module R = SubstantialRelation.Make (S)
-  module E = EphemeralRelation.Make (S)
+  module Sc = Schema.Make (S)
+  module SchemaM = Merkle.Interface (S) (Merkle.StringKey) (Sc)
+  module SMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
+  module SMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Sc)
+  module SMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
 
-  module Entry = struct
-    module Stored = EphemeralRelation.Persisted.Representation
-
-    type t = Substantial of R.t | Ephemeral of EphemeralRelation.Persisted.t
-
-    let encode = function
-      | Substantial relation -> R.encode relation
-      | Ephemeral relation -> Stored.to_blob relation
-
-    let decode blob =
-      let open Utilities.Result in
-      let open Concepts.Encoding in
-      let* data = Bencode.of_blob blob in
-      match data with
-      | Bencode.Tagged (tag, _) when Char.equal tag Stored.tag ->
-          Stored.of_bencode data |> Result.map (fun relation -> Ephemeral relation)
-      | _ -> R.Representation.of_bencode data |> Result.map (fun relation -> Substantial relation)
-
-    let load ?bind storage = function
-      | Substantial relation -> R.load storage relation
-      | Ephemeral relation -> E.load ?bind storage relation
-  end
-
-  module RelationM = Merkle.Interface (S) (Merkle.StringKey) (Entry)
-  module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
-  module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
-  module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
-
-  type t = {relations: RelationM.address}
+  type t = {schemas: SchemaM.address}
 
   module Error = struct
     open Concepts.Condition
@@ -57,20 +32,25 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let tag = '*'
     let malformed = Error.malformed_multigroup
 
-    let fields {relations} =
+    let fields {schemas} =
       let open Concepts.Encoding in
-      ["relations", Value.bencode_of_hash relations]
+      ["schemas", Value.bencode_of_hash schemas]
 
     let of_fields fields =
       let open Utilities.Result in
       let open Concepts.Encoding in
-      let* relations = Bencode.field "relations" fields |> fmap Value.hash_of_bencode in
-      Ok {relations}
+      let* schemas = Bencode.field "schemas" fields |> fmap Value.hash_of_bencode in
+      Ok {schemas}
   end
 
   let encode = Representation.to_blob
   let decode = Representation.of_blob
 
+  let node_of tx multigroup =
+    let open Utilities.Result in
+    SchemaM.find tx multigroup.schemas
+    |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup.schemas))
+
   class multigroup ?bind conn value node =
     object (self)
       inherit Lifecycle.null
@@ -88,8 +68,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
         let* node' =
           SI.with_transaction storage (fun tx ->
               let* _ = SI.store_blob tx (Representation.to_blob multigroup') in
-              RelationM.find tx multigroup'.relations
-              |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) )
+              node_of tx multigroup' )
         in
         new multigroup ?bind storage multigroup' node' |> Protocols.Handle.make |> Result.ok
 
@@ -99,37 +78,73 @@ module Make (S : Abstract.Storage.STORAGE) = struct
           [ Addressable.make self;
             Prototype.Associative.(
               of_properties
-                [ ( "relation",
+                [ ( "schema",
                     update_only (fun node' ->
                         Handle.require Addressable.from node'
                         |> Result.map Addressable.address
-                        |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
+                        |> fmap (fun addr -> self#deriving {schemas= addr}) ) ) ] );
             Prototype.Directory.of_properties
-              [ ( "relation",
+              [ ( "schema",
                   Prototype.mixture_of node (fun make node ->
-                      [ RMAddressable.make ~node:(RelationM.into node);
-                        RMDirectory.make ~storage ~node ~constructor:(Entry.load ?bind storage);
-                        RMAssociative.make ~storage ~node:(RelationM.into node)
-                          ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] )
-                ) ] ]
+                      [ SMAddressable.make ~node:(SchemaM.into node);
+                        SMDirectory.make ~storage ~node ~constructor:(Sc.load ?bind storage);
+                        SMAssociative.make ~admit:Sc.admit ~storage ~node:(SchemaM.into node)
+                          ~constructor:(fun node' -> SchemaM.from node' |> make |> Result.ok)
+                          () ] ) ) ] ]
 
       method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob
       method address = self#hash
     end
 
-  let wrap ?bind conn value =
+  let load ?bind conn value =
     let open Utilities.Result in
-    let* node =
-      SI.with_transaction conn (fun tx -> RelationM.find tx value.relations)
-      |> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations))
-    in
+    let* node = SI.with_read conn (fun tx -> node_of tx value) in
     new multigroup ?bind conn value node |> Protocols.Handle.make |> Result.ok
 
   let make conn =
     let open Utilities.Result in
     SI.with_transaction conn (fun tx ->
-        let* empty = RelationM.empty_under tx in
-        let multigroup = {relations= empty} in
+        let* empty = SchemaM.empty_under tx in
+        let multigroup = {schemas= empty} in
         let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
-        new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok )
+        new multigroup conn multigroup SchemaM.empty |> Protocols.Handle.make |> Result.ok )
+
+  (* Handed over as the tree shows one, a directory holding its schemas
+     under \schema, a multigroup not stored yet is stored with them. *)
+  let admit _ h =
+    let open Utilities.Result in
+    let* listing = Protocols.Handle.require Protocols.Directory.from h in
+    let* schemas = Protocols.Directory.find listing "schema" in
+    let* schemas =
+      match schemas with
+      | None -> Ok []
+      | Some schemas ->
+          let* listing = Protocols.Handle.require Protocols.Directory.from schemas in
+          let* names = Protocols.Directory.list listing in
+          BatFingerTree.to_list names
+          |> List.filter_map (fun name ->
+              match Protocols.Directory.find listing name with
+              | Ok None -> None
+              | Error c -> Some (Error c)
+              | Ok (Some schema) -> (
+                match Protocols.Addressable.from schema with
+                | Some a ->
+                    let addr = Protocols.Addressable.address a in
+                    Some (Ok (name, fun _ -> Ok addr))
+                | None -> Some (Sc.admit name schema |> Result.map (fun p -> name, p)) ) )
+          |> Utilities.List.sequence
+    in
+    Ok
+      (fun tx ->
+        let* _ = SchemaM.empty_under tx in
+        let* node =
+          SchemaM.with_batch tx (fun () ->
+              List.fold_left
+                (fun node (name, store) ->
+                  let* node = node in
+                  let* addr = store tx in
+                  SchemaM.Tree.insert tx name addr (SchemaM.into node) |> Result.map SchemaM.from )
+                (Ok SchemaM.empty) schemas )
+        in
+        SI.store_blob tx (Representation.to_blob {schemas= SchemaM.hash_of node}) )
 end