From 6b4f90c6c0b3a2265140f045512004090e2f28e6 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 24 Sep 2026 01:11:45 +0000 Subject: `assoc` on associatives --- lib/Utilities.ml | 4 ++++ lib/Utilities.mli | 4 ++++ lib/kernel/Path.ml | 41 +++++++++++++++++++++++++---------------- lib/kernel/Path.mli | 1 + 4 files changed, 34 insertions(+), 16 deletions(-) (limited to 'lib') diff --git a/lib/Utilities.ml b/lib/Utilities.ml index 404d8aa..fb5a7b3 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -104,3 +104,7 @@ module Atomic = struct then Ok atom else mswap atom f end + +module Fun = struct + let ( |.| ) = Fun.compose +end diff --git a/lib/Utilities.mli b/lib/Utilities.mli index 11c4487..2b9591c 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -34,3 +34,7 @@ module FingerTree : sig val join : string BatFingerTree.t -> string -> string end + +module Fun : sig + val ( |.| ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +end diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index 629a527..25ce09a 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -15,32 +15,41 @@ module Error = struct let path_not_found path = condition "path-not-found" "A given path was not found under the specified object" ("path" |=| Concepts.Value.String (to_string path)) - - let not_a_registry path = condition "not-a-registry" "The specified path did not point to a registry" - ("path" |=| Concepts.Value.String (to_string path)) - - let not_a_directory path = condition "not-a-directory" "The specified path did not point to a directory" - ("path" |=| Concepts.Value.String (to_string path)) end -let lookup handle path = +let walking f g handle path = let rec walk handle = function - | [] -> Ok handle + | [] -> g handle | x::xs -> let open Utilities.Result in let open Protocols in - match Directory.from handle with + let* dir = Handle.require Directory.from handle in + let* elem = Directory.find dir x in + match elem with | None -> Error (Error.path_not_found path) - | Some dir -> - let* elem = Directory.find dir x in - match elem with - | None -> Error (Error.not_a_directory path) - | Some elem -> walk elem xs + | Some elem -> f x handle (fun () -> walk elem xs) in walk handle path +let lookup = walking (fun _ _ f -> f ()) Result.ok + let update handle path key reference value = let open Utilities.Result in + let open Protocols in let* handle = lookup handle path in - let* registry = Protocols.Registry.from handle |> Option.to_result ~none:(Error.not_a_registry path) in - Protocols.Registry.update registry key reference value + let* registry = Handle.require Registry.from handle in + Registry.update registry key reference value + +let assoc handle path key value = + let open Utilities.Result in + let open Utilities.Fun in + let open Protocols in + let assoc_on handle key value = + let* a = Handle.require Associative.from handle in + let* a' = Associative.update a key value in + Ok (Handle.from a') + in + walking + (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some)) + (fun h -> assoc_on h key value) + handle path diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli index 6a74350..ece0615 100644 --- a/lib/kernel/Path.mli +++ b/lib/kernel/Path.mli @@ -6,3 +6,4 @@ val (@/) : string -> t -> t val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result val update : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> Protocols.Handle.t option -> (bool, Concepts.Condition.condition) result +val assoc : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result -- cgit v1.2.3 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/evaluators/FOL.ml | 2 ++ lib/evaluators/Lambda.ml | 3 +++ lib/kernel/Branch.ml | 2 ++ lib/kernel/BranchManager.ml | 2 ++ lib/kernel/Generator.ml | 2 ++ lib/kernel/Multigroup.ml | 2 ++ lib/kernel/Namespace.ml | 2 ++ lib/kernel/Prototype.ml | 2 ++ lib/kernel/SubstantialRelation.ml | 3 +++ lib/kernel/Tuple.ml | 2 ++ lib/protocols/Handle.ml | 10 +++++++--- lib/protocols/Handle.mli | 2 ++ 12 files changed, 31 insertions(+), 3 deletions(-) (limited to 'lib') diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml index b290e0a..eba57a1 100644 --- a/lib/evaluators/FOL.ml +++ b/lib/evaluators/FOL.ml @@ -31,6 +31,8 @@ class evaluator = object (self) inherit Kernel.Lifecycle.null inherit Kernel.Identity.of_id + method to_string = "fol-evaluator" + method invoke = execute method protocols : Protocols.Handle.protocol list = [Program.make self] end diff --git a/lib/evaluators/Lambda.ml b/lib/evaluators/Lambda.ml index a75fc10..53b0301 100644 --- a/lib/evaluators/Lambda.ml +++ b/lib/evaluators/Lambda.ml @@ -98,6 +98,9 @@ let execute term = class evaluator = object (self) inherit Kernel.Lifecycle.null inherit Kernel.Identity.of_id + + method to_string = "lambda-evaluator" + method invoke program = execute program method protocols : Protocols.Handle.protocol list = [Program.make self] end 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`? *) diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index 1162b40..bda4233 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -28,6 +28,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct inherit Lifecycle.null inherit Identity.of_id + method to_string = "branch-manager" + val storage : S.connection = storage val label : string = label val head : M.node Atomic.t = Atomic.make head diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml index e4a15f8..10f6865 100644 --- a/lib/kernel/Generator.ml +++ b/lib/kernel/Generator.ml @@ -15,6 +15,8 @@ class producer_cursor produce on_release = inherit Lifecycle.null inherit Identity.of_id + method to_string = "producer-cursor" + val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self] method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result = diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index 685c8c7..e5e36cf 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -41,6 +41,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct class multigroup conn value node = object inherit Lifecycle.null + method to_string = "multigroup" + val multigroup = value val storage = conn val node = node (* FIXME: see the comment on Branch.ml *) diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml index 507afa4..728c307 100644 --- a/lib/kernel/Namespace.ml +++ b/lib/kernel/Namespace.ml @@ -2,6 +2,8 @@ class namespace = object (self) inherit Lifecycle.null inherit Identity.of_id + method to_string = "namespace" + val entries : (string, Protocols.Handle.t) BatMap.t Atomic.t = Atomic.make BatMap.empty diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml index 65de68f..1d0751a 100644 --- a/lib/kernel/Prototype.ml +++ b/lib/kernel/Prototype.ml @@ -4,6 +4,8 @@ let mixture ps = Protocols.Handle.make @@ inherit Identity.of_id (* Should we allow the user to override this? *) method protocols = ps + + method to_string = "mixture" end let rec mixture_of value f = diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index 0afc3f7..136c146 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -146,6 +146,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct class relation storage value = object (self) inherit Lifecycle.null + + method to_string = "relation" + val storage : S.connection = storage val relation : t = value method predicate = Ok relation.predicate diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml index ef591ae..bbc20ab 100644 --- a/lib/kernel/Tuple.ml +++ b/lib/kernel/Tuple.ml @@ -117,6 +117,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct class tuple ~relation conn value node = object (self) inherit Lifecycle.null + method to_string = "tuple" + val tuple = value val storage = conn val node = node diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index cb78cf2..c45afb0 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -3,14 +3,16 @@ type protocol = .. module Error = struct open Concepts.Condition - let unimplemented_protocol () = condition "unimplemented-protocol" "A required protocol was not implemented by the specified object" - empty + let unimplemented_protocol obj_name = + condition "unimplemented-protocol" "A required protocol was not implemented by the specified object" + ("object" |=| Concepts.Value.String obj_name) end class type obj = object method reference : bool method release : unit method hash : Concepts.Hash.hash + method to_string : string method protocols : protocol list end @@ -50,9 +52,11 @@ let equal h1 h2 = let hash h = (object_of h)#hash +let to_string h = (object_of h)#to_string + let release ({ valid; _ } as handle) = let o = object_of handle in valid := false; o#release -let require f h = Option.to_result ~none:(Error.unimplemented_protocol ()) (f h) +let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h) diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index 5640b14..daee453 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -8,6 +8,7 @@ class type obj = object method reference : bool method release : unit method hash : Concepts.Hash.hash + method to_string : string method protocols : protocol list end @@ -23,5 +24,6 @@ val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash +val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result -- cgit v1.2.3 From 5a1088413468f171886d39339a8de96697af64c5 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Thu, 24 Sep 2026 02:17:01 +0000 Subject: Multigroup registration stub --- lib/kernel/Multigroup.ml | 23 +++++++++++++++++------ lib/kernel/Multigroup.mli | 2 +- lib/kernel/Path.ml | 5 ++++- 3 files changed, 22 insertions(+), 8 deletions(-) (limited to 'lib') diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index e5e36cf..c8ffa62 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -38,7 +38,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let encode = Representation.to_blob let decode = Representation.of_blob - class multigroup conn value node = object + class multigroup conn value node = object (self) inherit Lifecycle.null method to_string = "multigroup" @@ -48,15 +48,18 @@ module Make (S : Abstract.Storage.STORAGE) = struct val node = node (* FIXME: see the comment on Branch.ml *) method protocols : Protocols.Handle.protocol list = - [ Prototype.Directory.of_properties - [ "relation", Prototype.mixture - [ RMDirectory.make - ~storage ~node - ~constructor:(R.wrap storage) ] ] ] + Protocols.[ Addressable.make self; + Prototype.Directory.of_properties + [ "relation", Prototype.mixture + [ RMDirectory.make + ~storage ~node + ~constructor:(R.wrap storage) ] ] ] method hash = Representation.to_blob multigroup |> Concepts.Hash.hash_of_blob + + method address = self#hash end let wrap conn value = @@ -64,4 +67,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* node = SI.with_transaction conn (fun tx -> RelationM.find tx value.relations) |> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations)) in new multigroup 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* _ = SI.store_blob tx (Representation.to_blob multigroup) in + new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok) end diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli index 88aee30..fc58dad 100644 --- a/lib/kernel/Multigroup.mli +++ b/lib/kernel/Multigroup.mli @@ -5,5 +5,5 @@ module Make (S : Abstract.Storage.STORAGE) : sig val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result - + val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index 25ce09a..b83c9b2 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -23,13 +23,16 @@ let walking f g handle path = | x::xs -> let open Utilities.Result in let open Protocols in - let* dir = Handle.require Directory.from handle in + let* dir = + Handle.require Directory.from handle + |> Result.map_error Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x)) in let* elem = Directory.find dir x in match elem with | None -> Error (Error.path_not_found path) | Some elem -> f x handle (fun () -> walk elem xs) in walk handle path + |> Result.map_error Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path))) let lookup = walking (fun _ _ f -> f ()) Result.ok -- 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 ++++++++++++++++++++-------- lib/kernel/Prototype.ml | 12 ++++++++++++ lib/kernel/Prototype.mli | 7 +++++++ lib/kernel/Storage.ml | 4 ++-- lib/kernel/Storage.mli | 2 +- 5 files changed, 42 insertions(+), 11 deletions(-) (limited to 'lib') 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 diff --git a/lib/kernel/Prototype.ml b/lib/kernel/Prototype.ml index 1d0751a..b159e00 100644 --- a/lib/kernel/Prototype.ml +++ b/lib/kernel/Prototype.ml @@ -21,6 +21,18 @@ module Error = struct empty end +module Addressable = struct + module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY) = struct + module Tree = Merkle.Make (S) (K) + + let make ~node = + Protocols.Addressable.make @@ + object + method address = Tree.hash_of node + end + end +end + module Associative = struct let of_properties props = Protocols.Associative.make @@ diff --git a/lib/kernel/Prototype.mli b/lib/kernel/Prototype.mli index db55445..919f5d3 100644 --- a/lib/kernel/Prototype.mli +++ b/lib/kernel/Prototype.mli @@ -20,3 +20,10 @@ module Associative : sig val make : storage:S.connection -> constructor:(Tree.node -> (Protocols.Handle.t, Concepts.Condition.condition) result) -> node:Tree.node -> Protocols.Handle.protocol end end + +module Addressable : sig + module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY) : sig + module Tree : module type of Merkle.Make (S) (K) + val make : node:Tree.node -> Protocols.Handle.protocol + end +end diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml index dd06783..665b1a7 100644 --- a/lib/kernel/Storage.ml +++ b/lib/kernel/Storage.ml @@ -5,9 +5,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct loader : S.transaction -> S.address -> ('a, Concepts.Condition.condition) result } - let make addr loader = { addr; loader } + let make loader addr = { addr; loader } let address_of { addr; _ } = addr - let swap { loader; _ } addr = make addr loader + let swap { loader; _ } addr = make loader addr let deref tx { addr; loader } = loader tx addr end diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli index b8c0e5b..3c036ca 100644 --- a/lib/kernel/Storage.mli +++ b/lib/kernel/Storage.mli @@ -2,7 +2,7 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig module Pointer : sig type 'a t - val make : S.address -> (S.transaction -> S.address -> ('a, Concepts.Condition.condition) result) -> 'a t + val make : (S.transaction -> S.address -> ('a, Concepts.Condition.condition) result) -> S.address -> 'a t val address_of : 'a t -> S.address val swap : 'a t -> S.address -> 'a t val deref : S.transaction -> 'a t -> ('a, Concepts.Condition.condition) result -- 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') 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