From 320954996e921d7b34eb61f462799b5c6ab8ee09 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 26 Sep 2026 22:09:11 -0300 Subject: new shrunk API for RNT on sakura --- lib/RNT.ml | 231 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 231 insertions(+) create mode 100644 lib/RNT.ml (limited to 'lib/RNT.ml') diff --git a/lib/RNT.ml b/lib/RNT.ml new file mode 100644 index 0000000..173d09a --- /dev/null +++ b/lib/RNT.ml @@ -0,0 +1,231 @@ +open Utilities.Result +module S = Rnt.Backend.Storage.LMDB +module C = Rnt.Concepts +module P = Rnt.Protocols +module K = Rnt.Kernel +module FOL = Rnt.Evaluators.FOL +module I = K.Initialization.Make (S) +module B = K.Branch.Make (S) +module M = K.Multigroup.Make (S) +module SI = K.Storage.Make (S) +module SR = K.SubstantialRelation.Make (S) +module T = K.Tuple.Make (S) + +module Error = struct + open Condition + + let of_kernel c = + condition "kernel-condition" "RNT signalled a condition" + ("report" |=| Value.String (C.Condition.to_string_hum c)) + + let invalid_path path = + condition "invalid-path" "A path must start at \\ and have no empty segments" + ("path" |=| Value.String path) + + let unnamed path = + condition "unnamed-object" "The path does not name an object under a container" + ("path" |=| Value.String path) + + let conflict path = + condition "binding-conflict" + "The path did not hold what was expected when the change was applied" + ("path" |=| Value.String path) + + let unavailable path = + condition "unavailable-object" "The object refused a new reference" + ("path" |=| Value.String path) + + let heading_mismatch path = + condition "heading-mismatch" "A tuple does not conform to the heading of its relation" + ("path" |=| Value.String path) + + let not_a_relation name = + condition "not-a-relation" "The object does not describe itself as a relation" + ("object" |=| Value.String name) +end + +type kernel = {connection: S.connection; root: P.Handle.t} +type handle = P.Handle.t +type path = string +type tuple = {type_: string; attributes: Value.t Utilities.StringMap.t} +type batch = {tuples: tuple list; exhausted: bool} + +type blueprint = + | Namespace + | Branch + | Multigroup + | Relation of {heading: string Utilities.StringMap.t; tuples: Value.t Utilities.StringMap.t list} + +type plan = Base of path | Project of plan * string list + +let lift r = Result.map_error Error.of_kernel r +let value_of : C.Value.value -> Value.t = function String s -> String s | Integer n -> Integer n + +let kernel_value_of : Value.t -> C.Value.value = function + | String s -> String s + | Integer n -> Integer n + +let tuple_of ({type_; attributes} : C.Tuple.t) = + { type_; + attributes= + BatMap.String.fold + (fun name value -> Utilities.StringMap.add name (value_of value)) + attributes Utilities.StringMap.empty } + +let segments_of path = + match String.split_on_char '\\' path with + | [""; ""] -> Ok [] + | "" :: (_ :: _ as segments) when not (List.mem "" segments) -> Ok segments + | _ -> Error (Error.invalid_path path) + +let named path = + let* segments = segments_of path in + match List.rev segments with + | name :: parent -> Ok (List.rev parent, name) + | [] -> Error (Error.unnamed path) + +let using {root; _} segments f = + match segments with + | [] -> f root + | _ -> + let* handle = K.Path.lookup root (List.fold_right K.Path.( @/ ) segments K.Path.this) in + Fun.protect ~finally:(fun () -> P.Handle.release handle) (fun () -> f handle) + +let rec update kernel segments name reference value = + using kernel segments (fun target -> + match P.Registry.from target, List.rev segments with + | Some registry, _ -> P.Registry.update registry name reference value + | None, [] -> P.Handle.require P.Registry.from target |> Result.map (Fun.const false) + | None, last :: parent -> + let* directory = P.Handle.require P.Directory.from target in + let* present = P.Directory.find directory name in + Option.iter P.Handle.release present; + if Option.is_some present <> Option.is_some reference then Ok false + else + let* associative = P.Handle.require P.Associative.from target in + let* derived = P.Associative.update associative name value in + update kernel (List.rev parent) last (Some target) (Some (P.Handle.from derived)) ) + +let store_relation connection name heading tuples = + SI.with_transaction connection (fun tx -> + let* schematics = + C.Encoding.Bencode.( + Dict (Utilities.StringMap.bindings heading |> List.map (fun (a, d) -> a, String d)) + |> to_blob ) + |> SI.store_blob tx + in + let* _ = SR.TupleSet.empty_under tx in + let* node = + SR.TupleSet.with_batch tx (fun () -> + List.fold_left + (fun node attributes -> + let* node = node in + let tuple = + { C.Tuple.type_= name; + attributes= + Utilities.StringMap.fold + (fun a v -> BatMap.String.add a (kernel_value_of v)) + attributes BatMap.String.empty } + in + SR.TupleSet.insert tx (C.Tuple.hash tuple) tuple node ) + (Ok SR.TupleSet.empty) tuples ) + in + let relation = {SR.schematics; tuples= SR.TupleSet.hash_of node} in + let* _ = SI.store_blob tx (SR.encode relation) in + Ok relation ) + |> fmap (SR.load connection) + +let conforms heading attributes = + Utilities.StringMap.( + equal String.equal heading (map (fun v -> T.Attribute.domain (kernel_value_of v)) attributes) ) + +let make {connection; _} path name = function + | Namespace -> Ok (K.Namespace.make ()) + | Branch -> B.make connection |> lift + | Multigroup -> M.make connection |> lift + | Relation {heading; tuples} -> + if List.for_all (conforms heading) tuples then + store_relation connection name heading tuples |> lift + else Error (Error.heading_mismatch path) + +let initialize configuration = + let* connection = S.connect (C.Configuration.term_of_sexp configuration) |> lift in + (let* root = I.initialize ~evaluators:["fol", FOL.make ()] connection in + let* _ = K.Path.(update root this "session" None (Some (K.Namespace.make ()))) in + Ok {connection; root} ) + |> Result.map_error (fun c -> S.disconnect connection; Error.of_kernel c) + +let shutdown {connection; _} = S.disconnect connection + +let list kernel path = + let* segments = segments_of path in + using kernel segments (fun handle -> + let* directory = P.Handle.require P.Directory.from handle in + P.Directory.list directory ) + |> lift + |> Result.map BatFingerTree.to_list + +let lookup kernel path = + let* segments = segments_of path in + let* handle = using kernel segments (fun handle -> Ok (P.Handle.copy handle)) |> lift in + Option.to_result ~none:(Error.unavailable path) handle + +let create kernel path blueprint = + let* parent, name = named path in + let* value = make kernel path name blueprint in + let* bound = update kernel parent name None (Some value) |> lift in + if bound then Ok () else Error (Error.conflict path) + +let remove kernel path = + let* parent, name = named path in + let* current = lookup kernel path in + let removed = update kernel parent name (Some current) None in + P.Handle.release current; + let* removed = lift removed in + if removed then Ok () else Error (Error.conflict path) + +let release = P.Handle.release +let identity handle = P.Handle.hash handle |> C.Hash.to_hum_string + +let describe handle = + lift + (let* schematics = P.Handle.require P.Schematics.from handle in + P.Schematics.describe schematics ) + |> fmap (function + | P.Schematics.Relation description -> + Ok + (BatMap.String.fold + (fun name {P.Schematics.domain; _} -> Utilities.StringMap.add name domain) + description Utilities.StringMap.empty ) + | _ -> Error (Error.not_a_relation (P.Handle.to_string handle)) ) + +let rec fol_plan kernel = function + | Base path -> + let* relation = lookup kernel path in + Ok (FOL.Base relation, [relation]) + | Project (plan, attributes) -> + let* plan, relations = fol_plan kernel plan in + Ok (FOL.Project (plan, BatFingerTree.of_list attributes), relations) + +let execute kernel plan = + let* plan, relations = fol_plan kernel plan in + let program = FOL.program plan in + Fun.protect + ~finally:(fun () -> List.iter P.Handle.release (program :: relations)) + (fun () -> + using kernel ["evaluator"; "fol"] (fun evaluator -> + let* evaluator = P.Evaluator.require evaluator in + P.Evaluator.invoke evaluator program ) + |> lift ) + +let enumerate handle = + lift + (let* enumerable = P.Enumerable.require handle in + P.Enumerable.enumerate enumerable ) + +let fetch cursor limit = + lift + (let* scan = P.Cursor.require cursor in + P.Cursor.fetch scan limit ) + |> Result.map (fun ({tuples; exhausted} : P.Cursor.batch) -> + {tuples= BatFingerTree.to_list tuples |> List.map tuple_of; exhausted} ) -- cgit v1.2.3