diff options
Diffstat (limited to 'lib/kernel')
| -rw-r--r-- | lib/kernel/EphemeralRelation.ml | 1 | ||||
| -rw-r--r-- | lib/kernel/Lifecycle.ml | 1 | ||||
| -rw-r--r-- | lib/kernel/Lifecycle.mli | 1 | ||||
| -rw-r--r-- | lib/kernel/Multigroup.ml | 26 |
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 |