From 80b0e6fa676afaefbd3a6dc9edeab073343f0a2b Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Thu, 1 Oct 2026 00:53:12 -0300 Subject: fix multigroup deriving and tests --- lib/kernel/Multigroup.ml | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'lib') diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index 01675f0..1417a65 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -79,9 +79,31 @@ module Make (S : Abstract.Storage.STORAGE) = struct val storage = conn val node = node (* FIXME: see the comment on Branch.ml *) + (* TODO: Add later to the lifecycle management, accounting for + derived instances. Callers must release the previous handle + when done with it so its instance can be cleaned up after the + last reference is released. *) + 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_of node (fun make node -> -- cgit v1.2.3