aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/evaluators/FOL.ml11
-rw-r--r--lib/kernel/Merkle.ml19
-rw-r--r--lib/kernel/Multigroup.ml12
-rw-r--r--lib/kernel/Namespace.ml2
-rw-r--r--lib/kernel/SubstantialRelation.ml8
-rw-r--r--lib/kernel/Tuple.ml10
-rw-r--r--lib/protocols/Admission.ml10
7 files changed, 27 insertions, 45 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 99c4866..d5c6851 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -11,10 +11,6 @@ module Error = struct
let not_a_plan () =
condition "not-a-fol-program" "The evaluator was given a program of another kind" empty
- let not_a_relation name =
- condition "not-a-relation" "A plan named an object that does not describe itself as a relation"
- ("object" |=| Concepts.Value.String name)
-
let unknown_attribute name =
condition "unknown-attribute" "A plan projected an attribute its relation does not have"
("attribute" |=| Concepts.Value.String name)
@@ -109,12 +105,7 @@ let restrict attributes description =
let rec describe =
let open Utilities.Result in
function
- | Base relation -> (
- let* schematics = Protocols.Handle.require Protocols.Schematics.from relation in
- let* description = Protocols.Schematics.describe schematics in
- match description with
- | Protocols.Schematics.Relation description -> Ok description
- | _ -> Error (Error.not_a_relation (Protocols.Handle.to_string relation)) )
+ | Base relation -> Protocols.Relation.heading relation
| Project (plan, attributes) -> describe plan |> fmap (restrict attributes)
let rec modes =
diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml
index 4235914..266a560 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -29,6 +29,9 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig
val insert :
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 remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result
@@ -323,6 +326,16 @@ functor
let* _ = persist tx new_root in
Ok new_root
+ let of_list tx bindings =
+ let open Utilities.Result in
+ with_batch tx (fun () ->
+ let* _ = empty_under tx in
+ List.fold_left
+ (fun node (key, value) ->
+ let* node = node in
+ insert tx key value node )
+ (Ok empty) bindings )
+
let rec fold_left tx f acc =
let open Utilities.Result in
function
@@ -407,6 +420,7 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA
val empty_under : S.transaction -> (address, Concepts.Condition.condition) result
val hash_of : node -> address
val insert : S.transaction -> K.t -> V.t -> node -> (node, Concepts.Condition.condition) result
+ val of_list : S.transaction -> (K.t * V.t) list -> (node, Concepts.Condition.condition) result
val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result
val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result
val mem : S.transaction -> K.t -> node -> (bool, Concepts.Condition.condition) result
@@ -458,6 +472,11 @@ functor
let* addr = intern tx v in
Tree.insert tx k addr node
+ let of_list tx bindings =
+ List.map (fun (k, v) -> intern tx v |> Result.map (fun addr -> k, addr)) bindings
+ |> Utilities.List.sequence
+ |> fmap (Tree.of_list tx)
+
let remove = Tree.remove
let lookup tx k node =
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index e6135c6..13ca7e0 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -116,15 +116,9 @@ module Make (S : Abstract.Storage.STORAGE) = struct
|> Utilities.List.sequence
let tree_of tx admissions =
- let open Utilities.Result in
- let* _ = T.empty_under tx in
- T.with_batch tx (fun () ->
- List.fold_left
- (fun node (name, store) ->
- let* node = node in
- let* addr = store tx in
- T.insert tx name addr node )
- (Ok T.empty) admissions )
+ List.map (fun (name, store) -> store tx |> Result.map (fun addr -> name, addr)) admissions
+ |> Utilities.List.sequence
+ |> Utilities.Result.fmap (T.of_list tx)
let admit_schema _ h =
let open Utilities.Result in
diff --git a/lib/kernel/Namespace.ml b/lib/kernel/Namespace.ml
index c7c0767..80c446f 100644
--- a/lib/kernel/Namespace.ml
+++ b/lib/kernel/Namespace.ml
@@ -12,7 +12,7 @@ class namespace =
Utilities.Atomic.mswap entries (fun e ->
let existing = BatMap.find_opt key e in
if existing = reference then begin
- Option.map Protocols.Handle.release existing |> ignore;
+ Option.iter Protocols.Handle.release existing;
match value with
| Some v -> Ok (BatMap.add key (Protocols.Handle.move v) e)
| None -> Ok (BatMap.remove key e)
diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 09aec90..9cb57f0 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -144,14 +144,8 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let store tx description tuples =
let open Utilities.Result in
let* schematics = store_schema tx description in
- let* _ = TupleSet.empty_under tx in
let* node =
- TupleSet.with_batch tx (fun () ->
- List.fold_left
- (fun node tuple ->
- let* node = node in
- TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node )
- (Ok TupleSet.empty) tuples )
+ TupleSet.of_list tx (List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples)
in
let relation = {schematics; tuples= TupleSet.hash_of node} in
let* _ = SI.store_blob tx (encode relation) in
diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml
index 9dbbc17..41babe9 100644
--- a/lib/kernel/Tuple.ml
+++ b/lib/kernel/Tuple.ml
@@ -89,15 +89,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
let make tx ~type_ attributes =
let open Utilities.Result in
- let* node =
- AttributeM.with_batch tx (fun () ->
- BatMap.String.enum attributes
- |> BatEnum.fold
- (fun node (name, value) ->
- let* node = node in
- AttributeM.insert tx name value node )
- (Ok AttributeM.empty) )
- in
+ let* node = AttributeM.of_list tx (BatMap.String.bindings attributes) in
Ok {type_; attributes= AttributeM.hash_of node}
let attribute tx tuple name =
diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml
index c29f192..16ee965 100644
--- a/lib/protocols/Admission.ml
+++ b/lib/protocols/Admission.ml
@@ -1,11 +1,3 @@
-module Error = struct
- open Concepts.Condition
-
- let not_admitting () =
- condition "not-admitting" "A handle was expected to carry the admission protocol and did not"
- empty
-end
-
type violations = (string * Concepts.Tuple.t) list
class type implementation = object
@@ -17,5 +9,5 @@ type t = implementation
let make impl = Admission (impl :> implementation)
let from handle = Handle.into handle (function Admission impl -> Some impl | _ -> None)
-let require handle = from handle |> Option.to_result ~none:(Error.not_admitting ())
+let require = Handle.require from
let check i = Handle.invoke i (fun o -> o#check)
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 01:54:27 +0000