From e76cc6f862656a3ada9fa3d4418bd060df937885 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 31 Oct 2026 02:27:40 -0300 Subject: format and where claude on fol --- lib/kernel/Branch.ml | 3 +- lib/kernel/Generator.ml | 16 ++++++ lib/kernel/Merkle.ml | 5 +- lib/kernel/Multigroup.ml | 11 +++- lib/kernel/Scope.ml | 12 +++- lib/kernel/SubstantialRelation.ml | 114 +++++++++++++++++++++++++++++++------- 6 files changed, 133 insertions(+), 28 deletions(-) (limited to 'lib/kernel') diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 6f851ed..060efae 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -133,7 +133,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct object method check = let* named = Directory.children multigroups in - Utilities.List.concat_mapm admits (BatFingerTree.to_list named) (* FIXME: use finger trees *) + Utilities.List.concat_mapm admits (BatFingerTree.to_list named) + (* FIXME: use finger trees *) end; Prototype.Associative.( of_properties diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml index b83de3b..a037b3d 100644 --- a/lib/kernel/Generator.ml +++ b/lib/kernel/Generator.ml @@ -53,3 +53,19 @@ class producer_cursor produce finally = end let cursor_of ?finally produce = new producer_cursor produce finally |> Protocols.Handle.make + +let filter keep cursor = + cursor_of + ~finally:(fun () -> Protocols.Handle.release cursor) + (fun ~yield -> + let open Utilities.Result in + let* scan = Protocols.Cursor.require cursor in + let rec pass () = + let* next = Protocols.Cursor.next scan in + match next with + | None -> Ok () + | Some tuple -> + if keep tuple then yield tuple; + pass () + in + pass () ) diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 4882ec4..b8599d5 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -30,7 +30,10 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result val of_list : S.transaction -> (K.t * address) list -> (node, Concepts.Condition.condition) result - val of_finger_tree : S.transaction -> (K.t * address) BatFingerTree.t -> (node, Concepts.Condition.condition) result + + val of_finger_tree : + S.transaction -> (K.t * address) BatFingerTree.t -> (node, Concepts.Condition.condition) result + val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index f28abc4..84ef3f8 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -112,7 +112,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct let open Utilities.Result in let* listing = Protocols.Handle.require Protocols.Directory.from h in let* found = Protocols.Directory.find listing property in - let* children = Option.fold ~none:(Ok BatFingerTree.empty) ~some:Protocols.Directory.children found in + let* children = + Option.fold ~none:(Ok BatFingerTree.empty) ~some:Protocols.Directory.children found + in BatFingerTree.map (fun (name, child) -> Prototype.Associative.admission admit name child |> Result.map (fun p -> name, p) ) @@ -121,7 +123,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct let tree_of tx admissions = let open Utilities.Result in - BatFingerTree.map (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) admissions + BatFingerTree.map + (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) + admissions |> Utilities.FingerTree.sequence |>> T.of_finger_tree tx @@ -227,7 +231,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct method check = let open Utilities.Result in let* named = Protocols.Directory.children (relations ?bind storage denial_tree) in - let named = BatFingerTree.to_list named in (* FIXME *) + let named = BatFingerTree.to_list named in + (* FIXME *) Utilities.List.concat_mapm (held ?bind) named method protocols : Protocols.Handle.protocol list = diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml index ba9c1e0..817da97 100644 --- a/lib/kernel/Scope.ml +++ b/lib/kernel/Scope.ml @@ -44,7 +44,9 @@ let attribute home relation text = (* every relation of a branch state, as multigroup:schema:relation *) let catalog_of branch = let open Utilities.Result in - let name prefix last = Utilities.FingerTree.join (BatFingerTree.reverse (BatFingerTree.cons prefix last)) ":" in + let name prefix last = + Utilities.FingerTree.join (BatFingerTree.reverse (BatFingerTree.cons prefix last)) ":" + in let rec down prefix handle properties = let* level = Path.find handle Path.(List.hd properties @/ this) in match level, List.tl properties with @@ -55,7 +57,9 @@ let catalog_of branch = Ok (BatFingerTree.map (name prefix) names) | Some level, rest -> let* named = Protocols.Directory.children level in - Utilities.FingerTree.concat_mapm (fun (n, child) -> down (BatFingerTree.cons prefix n) child rest) named + Utilities.FingerTree.concat_mapm + (fun (n, child) -> down (BatFingerTree.cons prefix n) child rest) + named in down BatFingerTree.empty branch ["multigroup"; "schema"; "relation"] @@ -88,7 +92,9 @@ let rec make branch home = let* previous = Path.find branch Path.("previous" @/ this) in Ok (Option.map (fun p -> make p home) previous) - method catalog = catalog_of branch |> Result.map BatFingerTree.to_list (* FIXME: use finger trees thoroughly *) + method catalog = + catalog_of branch + |> Result.map BatFingerTree.to_list (* FIXME: use finger trees thoroughly *) end ] let heads = Path.("system" @/ "branch" @/ this) diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index fe9e34f..3e7945d 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -19,6 +19,20 @@ module Make (S : Abstract.Storage.STORAGE) = struct "The tuple-set root for a substantial relation is missing from the backend. Either your \ storage is corrupted, or this is a bug in RNT!" ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string root)) + + let missing_attribute name = + condition "missing-attribute" "A tuple to store has no value for an attribute of its relation" + ("attribute" |=| Concepts.Value.String name) + + let unindexed_attribute name = + condition "unindexed-attribute" "A relation was looked up on an attribute it has no index for" + ("attribute" |=| Concepts.Value.String name) + + let invalid_index_root root = + condition "invalid-index-root" + "An index root for a substantial relation is missing from the backend. Either your storage \ + is corrupted, or this is a bug in RNT!" + ("hash" |=| Concepts.Value.String (Concepts.Hash.to_hum_string root)) end module TupleKey = struct @@ -42,8 +56,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct end module TupleSet = Merkle.Interface (S) (TupleKey) (TupleValue) + module Index = Merkle.Make (S) (Merkle.StringKey) - type t = {schematics: Concepts.Hash.hash; tuples: TupleSet.address} + type t = + { schematics: Concepts.Hash.hash; + tuples: TupleSet.address; + indexes: Index.address BatMap.String.t } module rec Representation : (Concepts.Encoding.Record.S with type t = t) = Concepts.Encoding.Record.Make (Body) @@ -54,16 +72,26 @@ module Make (S : Abstract.Storage.STORAGE) = struct let tag = 'R' let malformed = Error.malformed_relation - let fields {schematics; tuples} = + let fields {schematics; tuples; indexes} = let open Concepts.Encoding in - ["schema", Value.bencode_of_hash schematics; "tuples", Value.bencode_of_hash tuples] + [ "schema", Value.bencode_of_hash schematics; + "tuples", Value.bencode_of_hash tuples; + ( "indexes", + Bencode.Dict + (BatMap.String.bindings indexes |> List.map (fun (a, h) -> a, Value.bencode_of_hash h)) + ) ] let of_fields fields = let open Utilities.Result in let open Concepts.Encoding in let* schematics = Bencode.field "schema" fields |>> Value.hash_of_bencode in let* tuples = Bencode.field "tuples" fields |>> Value.hash_of_bencode in - Ok {schematics; tuples} + let* indexes = Bencode.field "indexes" fields |>> Bencode.as_dict in + let* indexes = + List.map (fun (a, h) -> Value.hash_of_bencode h |> Result.map (fun h -> a, h)) indexes + |> Utilities.List.sequence + in + Ok {schematics; tuples; indexes= BatMap.String.of_list indexes} end let encode = Representation.to_blob @@ -94,14 +122,40 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> Utilities.List.sequence |> Result.map BatMap.String.of_list - let enumerate connection relation = + let prefix value = + Concepts.Encoding.Bencode.to_bytes (Concepts.Tuple.bencode_of_value value) |> Bytes.to_string + + let reading connection start walk = let open Utilities.Result in let* tx = S.start_read connection in let close () = ignore (S.abort tx) in - let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in - Ok - (Generator.cursor_of ~finally:close (fun ~yield -> - TupleSet.iter tx (fun _ tuple -> yield tuple) node ) ) + let* node = start tx |> Result.map_error (fun c -> close (); c) in + Ok (Generator.cursor_of ~finally:close (walk tx node)) + + let enumerate connection relation = + reading connection + (fun tx -> tuple_node tx relation) + (fun tx node ~yield -> TupleSet.iter tx (fun _ tuple -> yield tuple) node) + + let lookup connection relation attribute value = + let open Utilities.Result in + let* root = + BatMap.String.find_opt attribute relation.indexes + |> Option.to_result ~none:(Error.unindexed_attribute attribute) + in + let prefix = prefix value in + reading connection + (fun tx -> Index.find tx root |>> Option.to_result ~none:(Error.invalid_index_root root)) + (fun tx node ~yield -> + Index.fold_left ~from:prefix + ~until:(fun key -> not (String.starts_with ~prefix key)) + tx + (fun read _ address -> + let* () = read in + let* tuple = SI.get_req tx (S.Hash address) |>> TupleValue.decode in + Ok (yield tuple) ) + (Ok ()) node + |> Result.join ) class substantial_relation connection value description = object (self) @@ -118,11 +172,13 @@ module Make (S : Abstract.Storage.STORAGE) = struct method modes = Ok - Concepts. - [ Mode.mode [] Cardinality.Finite; - Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1) - ] + Concepts.( + Mode.mode [] Cardinality.Finite + :: Mode.mode (List.map fst (BatMap.String.bindings description)) (Cardinality.bounded 1) + :: List.map (fun a -> Mode.mode [a] Cardinality.Finite) self#indexes ) + method indexes = List.map fst (BatMap.String.bindings relation.indexes) + method lookup attribute value = lookup connection relation attribute value method describe () = Ok (Protocols.Schematics.Relation description) method enumerate = enumerate connection relation @@ -130,6 +186,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct [ Protocols.Addressable.make self; Protocols.Relation.make self; Protocols.Enumerable.make self; + Protocols.Indexed.make self; Protocols.Schematics.make self ] method hash = encode relation |> Concepts.Hash.hash_of_blob @@ -141,13 +198,32 @@ module Make (S : Abstract.Storage.STORAGE) = struct |> Result.map (fun description -> new substantial_relation connection relation description |> Protocols.Handle.make ) + let index tx attribute hashed = + let open Utilities.Result in + let* entries = + List.map + (fun (hash, tuple) -> + match BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes with + | Some value -> Ok (prefix value ^ Concepts.Hash.to_raw_string hash, hash) + | None -> Error (Error.missing_attribute attribute) ) + hashed + |> Utilities.List.sequence + in + Index.of_list tx entries |> Result.map (fun node -> attribute, Index.hash_of node) + let store tx description tuples = let open Utilities.Result in let* schematics = store_schema tx description in - let* node = - TupleSet.of_list tx (List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples) + let hashed = List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples in + let* node = TupleSet.of_list tx hashed in + let* indexes = + BatMap.String.bindings description + |> List.map (fun (attribute, _) -> index tx attribute hashed) + |> Utilities.List.sequence + in + let relation = + {schematics; tuples= TupleSet.hash_of node; indexes= BatMap.String.of_list indexes} in - let relation = {schematics; tuples= TupleSet.hash_of node} in let* _ = SI.store_blob tx (encode relation) in Ok relation @@ -155,10 +231,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct let open Utilities.Result in let* relation = SI.with_transaction connection (fun tx -> - let* tuples = TupleSet.empty_under tx in - let relation = {schematics; tuples} in - let* _ = SI.store_blob tx (encode relation) in - Ok relation ) + let* description = schema_of tx schematics in + store tx description [] ) in load connection relation end -- cgit v1.2.3