diff options
| -rw-r--r-- | lib/evaluators/FOL.ml | 40 | ||||
| -rw-r--r-- | lib/kernel/Initialization.ml | 12 | ||||
| -rw-r--r-- | lib/kernel/Initialization.mli | 5 | ||||
| -rw-r--r-- | lib/protocols/Program.ml | 31 | ||||
| -rw-r--r-- | lib/protocols/Program.mli | 36 | ||||
| -rw-r--r-- | test/integration/Registration.ml | 11 | ||||
| -rw-r--r-- | test/test_rnt.ml | 1 | ||||
| -rw-r--r-- | test/unit/evaluators/FOL.ml | 71 | ||||
| -rw-r--r-- | test/unit/kernel/SubstantialRelation.ml | 51 |
9 files changed, 203 insertions, 55 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml new file mode 100644 index 0000000..70cf9de --- /dev/null +++ b/lib/evaluators/FOL.ml @@ -0,0 +1,40 @@ +module Error = struct + open Concepts.Condition + + let unknown_relation name = + condition "unknown-relation" "A plan named a relation that does not exist under this snapshot" + ("name" |=| Concepts.Value.String name) + + let cancelled () = + condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty +end + +type plan = Base of string + +module Program = Protocols.Program.Make (struct + type t = plan +end) + +let execute context = function + | Base name -> + let open Utilities.Result in + match context.Protocols.Context.status () with + | `Cancelled | `Exhausted -> Error (Error.cancelled ()) + | `Live -> + let* found = Runtime.Context.resolve context name in + let* handle = Option.to_result ~none:(Error.unknown_relation name) found in + Fun.protect + ~finally:(fun () -> Protocols.Handle.release handle) + (fun () -> + let* enumerable = Protocols.Enumerable.require handle in + Protocols.Enumerable.enumerate enumerable context) + +class evaluator = object (self) + inherit Kernel.Lifecycle.null + inherit Kernel.Identity.of_id + + method invoke ~program context = execute context program + method protocols : Protocols.Handle.protocol list = [Program.make self] +end + +let make () = new evaluator |> Protocols.Handle.make diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index d213b66..ae041fc 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -1,12 +1,22 @@ module Make (S : Abstract.Storage.STORAGE) = struct module BM = BranchManager.Make (S) - let initialize conn = + let initialize ?(evaluators = []) conn = let open Utilities.Result in let open Protocols in let root = Namespace.make () in let registry = Registry.from root |> Option.get in let* branch_manager = BM.make conn "rnt-head" in let* _ = Registry.update registry "branch" None (Some branch_manager) in + let evaluator_namespace = Namespace.make () in + let evaluator_registry = Registry.from evaluator_namespace |> Option.get in + let* _ = + List.fold_left + (fun acc (name, handle) -> + let* _ = acc in + Registry.update evaluator_registry name None (Some handle)) + (Ok true) evaluators + in + let* _ = Registry.update registry "evaluator" None (Some evaluator_namespace) in Ok root end diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli index 104d523..926bbd8 100644 --- a/lib/kernel/Initialization.mli +++ b/lib/kernel/Initialization.mli @@ -1,3 +1,6 @@ module Make (S : Abstract.Storage.STORAGE) : sig - val initialize : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result + val initialize : + ?evaluators:(string * Protocols.Handle.t) list -> + S.connection -> + (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/protocols/Program.ml b/lib/protocols/Program.ml index b82cafc..49e6e2d 100644 --- a/lib/protocols/Program.ml +++ b/lib/protocols/Program.ml @@ -1,17 +1,20 @@ -class type implementation = object - method entry_points : string BatFingerTree.t - - method invoke : - entry:string -> - bindings:Concepts.Tuple.t -> - Context.t -> - (Handle.t, Concepts.Condition.condition) result +module type PROGRAM = sig + type t end -type Handle.protocol += Program of implementation -type t = implementation +module Make (P : PROGRAM) = struct + class type implementation = object + method invoke : + program:P.t -> + Context.t -> + (Handle.t, Concepts.Condition.condition) result + end + + type Handle.protocol += Program of implementation -let make impl = Program (impl :> implementation) -let from handle = Handle.into handle (function Program impl -> Some impl | _ -> None) -let entry_points i = Handle.invoke i (fun o -> o#entry_points) -let invoke i ~entry ~bindings ctx = Handle.invoke i (fun o -> o#invoke ~entry ~bindings ctx) + type t = implementation + + let make impl = Program (impl :> implementation) + let from handle = Handle.into handle (function Program impl -> Some impl | _ -> None) + let invoke i ~program ctx = Handle.invoke i (fun o -> o#invoke ~program ctx) +end diff --git a/lib/protocols/Program.mli b/lib/protocols/Program.mli index a795f16..1d6c3ae 100644 --- a/lib/protocols/Program.mli +++ b/lib/protocols/Program.mli @@ -1,21 +1,23 @@ -type t +module type PROGRAM = sig + type t +end + +module Make (P : PROGRAM) : sig + type t + + class type implementation = object + method invoke : + program:P.t -> + Context.t -> + (Handle.t, Concepts.Condition.condition) result + end -class type implementation = object - method entry_points : string BatFingerTree.t - method invoke : - entry:string -> - bindings:Concepts.Tuple.t -> + val make : #implementation -> Handle.protocol + val from : Handle.t -> t Handle.interface option + + val invoke : + t Handle.interface -> + program:P.t -> Context.t -> (Handle.t, Concepts.Condition.condition) result end - -val make : #implementation -> Handle.protocol -val from : Handle.t -> t Handle.interface option -val entry_points : t Handle.interface -> string BatFingerTree.t - -val invoke : - t Handle.interface -> - entry:string -> - bindings:Concepts.Tuple.t -> - Context.t -> - (Handle.t, Concepts.Condition.condition) result diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml index c77a139..991bafa 100644 --- a/test/integration/Registration.ml +++ b/test/integration/Registration.ml @@ -18,7 +18,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let open Protocols in let registration = begin - let* root = I.initialize conn in + let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in let* bm = Kernel.Path.(lookup root ("branch" @/ this)) |> fmap (Option.to_result ~none:(Error.not_found ())) in let* bm = Registry.from bm |> Option.to_result ~none:(Error.not_found ()) in @@ -35,8 +35,15 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = Directory.find bm "master" |> Result.map Option.is_some end |> Helpers.condition_as_failure in + let evaluator = + begin + let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in + Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) |> Result.map Option.is_some + end + |> Helpers.condition_as_failure in check bool "" true registration; - check bool "" true presence + check bool "" true presence; + check bool "the fol evaluator is registered" true evaluator let suite prefix = ( "registration/" ^ prefix, diff --git a/test/test_rnt.ml b/test/test_rnt.ml index b80de90..784689d 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -2,6 +2,7 @@ let all_suites = Unit.Backend.Storage.suites () @ Unit.Kernel.Merkle.suites () @ Unit.Kernel.SubstantialRelation.suites () + @ Unit.Evaluators.FOL.suites () @ Integration.Registration.suites () let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml new file mode 100644 index 0000000..32f09f5 --- /dev/null +++ b/test/unit/evaluators/FOL.ml @@ -0,0 +1,71 @@ +open Rnt + +module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct + open Alcotest + + module H = Helpers.Storage.Make (S) (C) + module SR = Rnt.Kernel.SubstantialRelation.Make (S) + + let hash s = + Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob + + let alaric = + { Concepts.Tuple.type_ = "employee"; + attributes = + BatMap.String.empty + |> BatMap.String.add "name" (Concepts.Value.String "Alaric") } + + let not_a_program () = + Concepts.Condition.condition "not-a-program" + "A handle was expected to carry the program protocol and did not" Concepts.Condition.empty + + let scan_a_base_relation conn = + let scanned = + begin + let open Utilities.Result in + let* tx = S.start conn in + let* relation = SR.empty tx ~schematics:(hash "schema") () in + let* relation = + SR.assert_tuple tx relation (Concepts.Tuple.Representation.to_blob alaric) + in + let* () = S.commit tx in + let* employee = SR.wrap conn relation in + let root = + Kernel.Prototype.mixture + [ Kernel.Prototype.Directory.of_properties + ["employee", employee; "fol", Rnt.Evaluators.FOL.make ()] ] + in + let context = Runtime.Context.over ~snapshot:(hash "snapshot") ~root () in + let* found = Runtime.Context.resolve context "fol" in + let* evaluator = Option.to_result ~none:(not_a_program ()) found in + let* interpreter = + Rnt.Evaluators.FOL.Program.from evaluator + |> Option.to_result ~none:(not_a_program ()) + in + let* cursor = + Rnt.Evaluators.FOL.Program.invoke interpreter + ~program:(Rnt.Evaluators.FOL.Base "employee") context + in + let* scan = Protocols.Cursor.require cursor in + let* tuples = Protocols.Cursor.drain scan () in + Protocols.Handle.release cursor; + Ok (BatFingerTree.to_list tuples) + end + |> Helpers.condition_as_failure + in + check int "one tuple scanned" 1 (List.length scanned); + check bool "the tuple that was asserted" true + (List.for_all + (fun tuple -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric)) + scanned) + + let suite prefix = + ( "fol/" ^ prefix, + [test_case "scan-a-base-relation" `Quick (H.with_connection scan_a_base_relation "fol-test")] + ) +end + +module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) + +let suites () = [LMDB.suite "lmdb"] diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml index e113a8c..9d60685 100644 --- a/test/unit/kernel/SubstantialRelation.ml +++ b/test/unit/kernel/SubstantialRelation.ml @@ -6,37 +6,48 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = module H = Helpers.Storage.Make (S) (C) module SR = Rnt.Kernel.SubstantialRelation.Make (S) - let blob s = Concepts.Blob.blob_of_bytes (Bytes.of_string s) - let hash s = blob s |> Concepts.Hash.hash_of_blob + let hash s = + Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob - let assert_and_load conn = - let tuple = blob "tuple/alaric" in - let original_contains, updated_contains, loaded_contains = + let alaric = + { Concepts.Tuple.type_ = "employee"; + attributes = + BatMap.String.empty + |> BatMap.String.add "name" (Concepts.Value.String "Alaric") + |> BatMap.String.add "age" (Concepts.Value.Integer 42) } + + let assert_and_enumerate conn = + let tuple = Concepts.Tuple.Representation.to_blob alaric in + let before, after, enumerated = begin let open Utilities.Result in let* tx = S.start conn in - let* original = SR.empty tx ~schematics:(hash "schema") () in - let* original_contains = SR.contains_tuple tx original tuple in - let* updated = SR.assert_tuple tx original tuple in - let* updated_contains = SR.contains_tuple tx updated tuple in - let* stored = SR.store tx updated in + let* relation = SR.empty tx ~schematics:(hash "schema") () in + let* before = SR.contains_tuple tx relation tuple in + let* relation = SR.assert_tuple tx relation tuple in + let* after = SR.contains_tuple tx relation tuple in let* () = S.commit tx in - let* tx = S.start conn in - let* loaded = SR.load_value tx stored in - let* loaded_contains = SR.contains_tuple tx loaded tuple in - let* () = S.abort tx in - Ok (original_contains, updated_contains, loaded_contains) + let* cursor = SR.enumerate conn relation in + let* scan = Protocols.Cursor.require cursor in + let* enumerated = Protocols.Cursor.drain scan () in + Protocols.Handle.release cursor; + Ok (before, after, BatFingerTree.to_list enumerated) end |> Helpers.condition_as_failure in - check bool "original" false original_contains; - check bool "updated" true updated_contains; - check bool "loaded" true loaded_contains + check bool "absent before assertion" false before; + check bool "present after assertion" true after; + check int "one tuple enumerated" 1 (List.length enumerated); + check bool "the tuple that was asserted" true + (List.for_all + (fun tuple -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric)) + enumerated) let suite prefix = ( "substantial-relation/" ^ prefix, - [ test_case "assert-and-load" `Quick - (H.with_connection assert_and_load "substantial-relation-test") ] ) + [ test_case "assert-and-enumerate" `Quick + (H.with_connection assert_and_enumerate "substantial-relation-test") ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) |