Fix build, allow users to register relationsrelation-registration

4 files changed, 28 insertions, 1 deletions

diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index 8aa0463..a837756 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -35,6 +35,7 @@ module Make (D : DERIVATION) = struct
       method predicate = Ok None
       method local_constraints = Ok None
       method modes = Ok declaration
+      method to_string = "ephemeral-relation"
 
       (* A cursor holds a reference to its relation, so the edges it reads
          outlive a release of the relation that produced it. *)
diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml
index bf0b544..68a2479 100644
--- a/lib/kernel/Lifecycle.ml
+++ b/lib/kernel/Lifecycle.ml
@@ -26,6 +26,7 @@ class retaining inner (owner : lifecycle) =
   object
     inherit counted
     initializer ignore owner#reference
+    method to_string = "retaining"
     method destroy = Protocols.Handle.release inner; owner#release
     method hash = Protocols.Handle.hash inner
     method protocols = Protocols.Handle.protocols inner
diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli
index fa3abee..12964b0 100644
--- a/lib/kernel/Lifecycle.mli
+++ b/lib/kernel/Lifecycle.mli
@@ -16,6 +16,7 @@ class virtual counted : controlled_lifecycle
     the object that produced it. *)
 class retaining : Protocols.Handle.t -> lifecycle -> object
   inherit lifecycle
+  method to_string : string
   method destroy : unit
   method hash : Concepts.Hash.hash
   method protocols : Protocols.Handle.protocol list
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 602f3a9..d53e1e1 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -2,7 +2,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   module SI = Storage.Make (S)
   module R = SubstantialRelation.Make (S)
   module RelationM = Merkle.Interface (S) (Merkle.StringKey) (R)
+  module RMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey)
   module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (R)
+  module RMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
 
   type t = {relations: RelationM.address}
 
@@ -52,12 +54,34 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       val storage = conn
       val node = node (* FIXME: see the comment on Branch.ml *)
 
+      method deriving multigroup' =
+        let open Utilities.Result in
+        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)) )
+        in
+        new multigroup storage multigroup' node' |> Protocols.Handle.make |> Result.ok
+
       method protocols : Protocols.Handle.protocol list =
+        let open Utilities.Result in
         Protocols.
           [ Addressable.make self;
+            Prototype.Associative.(
+              of_properties
+                [ ( "relation",
+                    update_only (fun node' ->
+                        Handle.require Addressable.from node'
+                        |> Result.map Addressable.address
+                        |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
             Prototype.Directory.of_properties
               [ ( "relation",
-                  Prototype.mixture [RMDirectory.make ~storage ~node ~constructor:(R.wrap storage)]
+                  Prototype.mixture_of node (fun make node ->
+                      [ RMAddressable.make ~node:(RelationM.into node);
+                        RMDirectory.make ~storage ~node ~constructor:(R.wrap storage);
+                        RMAssociative.make ~storage ~node:(RelationM.into node)
+                          ~constructor:(fun node' -> RelationM.from node' |> make |> Result.ok ) ] )
                 ) ] ]
 
       method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob