From 2d7c5b7c6696f39028ab07064ff75548d71ee5cf Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 24 Sep 2026 02:16:27 +0000 Subject: Make objects printable --- lib/kernel/Branch.ml | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lib/kernel/Branch.ml') diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index b8d331f..1e7794e 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -63,6 +63,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct class branch storage value node = object (self) inherit Lifecycle.null + method to_string = "branch" + val storage : S.connection = storage val branch : t = value val node = node (* FIXME: can we not place this inside `t`? *) -- cgit v1.2.3 From 721b1fda713a08bbc4f9a8e50820ce1491e32ff1 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 24 Sep 2026 04:25:50 +0000 Subject: Actually register the multigroup --- lib/kernel/Branch.ml | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) (limited to 'lib/kernel/Branch.ml') diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 1e7794e..4b9d948 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -12,6 +12,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct module MultigroupM = Merkle.Interface (S) (Merkle.StringKey) (M) module MMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (M) module MMAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey) + module MMAddressable = Prototype.Addressable.OfTree (S) (Merkle.StringKey) module Error = struct open Concepts.Condition @@ -29,10 +30,6 @@ module Make (S : Abstract.Storage.STORAGE) = struct and Body : Concepts.Encoding.Record.BODY = struct type nonrec t = t - let load tx addr = - SI.get_req tx addr - |> Utilities.Result.fmap Representation.of_blob - let tag = 'Y' let malformed () = Concepts.Condition. @@ -56,9 +53,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> fmap (Value.option_of_bencode (fun v -> Value.hash_of_bencode v |> Result.map (fun hash -> S.Hash hash) - |> Result.map (Fun.flip (SI.Pointer.make) load))) in + |> Result.map (SI.Pointer.make Loader.load))) in Ok { multigroups; previous } end + and Loader : sig val load : (S.transaction -> S.address -> (t, Concepts.Condition.condition) result) end = struct + let load tx addr = + SI.get_req tx addr + |> Utilities.Result.fmap Representation.of_blob + end class branch storage value node = object (self) inherit Lifecycle.null @@ -73,15 +75,25 @@ module Make (S : Abstract.Storage.STORAGE) = struct Protocols.[ Addressable.make self; Prototype.Associative.(of_properties [ "multigroup", update_only (fun node' -> + (* FIXME: most of this should not be here *) let open Utilities.Result in let* addressable = Handle.require Addressable.from node' in let addr = Addressable.address addressable in - ignore addr; - failwith "TODO") ]); + let branch' = { multigroups = addr; + previous = self#address + |> (fun hash -> S.Hash hash) + |> SI.Pointer.make Loader.load + |> Option.some } in + let* node' = SI.with_transaction storage (fun tx -> + let* _ = SI.store_blob tx (Representation.to_blob branch') in + MultigroupM.find tx addr |> fmap (Option.to_result ~none:(Error.incomplete_branch addr))) in + new branch storage branch' node' |> Protocols.Handle.make |> Result.ok) ]); Prototype.Directory.of_properties [ "multigroup", Prototype.mixture_of node (fun make node -> - [ MMDirectory.make + [ MMAddressable.make + ~node:(MultigroupM.into node); + MMDirectory.make ~storage ~node ~constructor:(M.wrap storage); MMAssociative.make -- cgit v1.2.3 From 0ec1e8a052305f5246d7cd66e11300cd29bc6d64 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Fri, 25 Sep 2026 23:57:03 +0000 Subject: Split that up a little --- lib/kernel/Branch.ml | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) (limited to 'lib/kernel/Branch.ml') diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 4b9d948..53f6fa1 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -17,8 +17,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct module Error = struct open Concepts.Condition - let incomplete_branch addr = condition "incomplete-branch" "A stored branch is missing part of its expected structure. Is your storage corrupted?" - ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr)) + let incomplete_branch addr = + condition "incomplete-branch" "A stored branch is missing part of its expected structure. Is your storage corrupted?" + ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr)) end type t = { @@ -62,6 +63,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> Utilities.Result.fmap Representation.of_blob end + let pointer_of hash = SI.Pointer.make Loader.load (S.Hash hash) + class branch storage value node = object (self) inherit Lifecycle.null @@ -71,23 +74,25 @@ module Make (S : Abstract.Storage.STORAGE) = struct val branch : t = value val node = node (* FIXME: can we not place this inside `t`? *) + method deriving branch' = + let open Utilities.Result in + let branch'' = { branch' with previous = self#address + |> pointer_of + |> Option.some } in + let* node' = SI.with_transaction storage (fun tx -> + let* _ = SI.store_blob tx (Representation.to_blob branch'') in + MultigroupM.find tx branch'.multigroups + |> fmap (Option.to_result ~none:(Error.incomplete_branch branch'.multigroups))) in + new branch storage branch'' 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 [ "multigroup", update_only (fun node' -> - (* FIXME: most of this should not be here *) - let open Utilities.Result in - let* addressable = Handle.require Addressable.from node' in - let addr = Addressable.address addressable in - let branch' = { multigroups = addr; - previous = self#address - |> (fun hash -> S.Hash hash) - |> SI.Pointer.make Loader.load - |> Option.some } in - let* node' = SI.with_transaction storage (fun tx -> - let* _ = SI.store_blob tx (Representation.to_blob branch') in - MultigroupM.find tx addr |> fmap (Option.to_result ~none:(Error.incomplete_branch addr))) in - new branch storage branch' node' |> Protocols.Handle.make |> Result.ok) ]); + Handle.require Addressable.from node' + |> Result.map Addressable.address + |> fmap (fun addr -> self#deriving { branch with multigroups = addr })) ]); Prototype.Directory.of_properties [ "multigroup", Prototype.mixture_of node (fun make node -> -- cgit v1.2.3