fol evaluator

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)