diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/evaluators/FOL.ml | 11 | ||||
| -rw-r--r-- | lib/kernel/EphemeralRelation.ml | 31 | ||||
| -rw-r--r-- | lib/kernel/Multigroup.ml | 36 | ||||
| -rw-r--r-- | test/integration/Registration.ml | 19 | ||||
| -rw-r--r-- | test/unit/evaluators/FOL.ml | 238 | ||||
| -rw-r--r-- | test/unit/kernel/Branch.ml | 183 | ||||
| -rw-r--r-- | test/unit/kernel/EphemeralRelation.ml | 36 | ||||
| -rw-r--r-- | test/unit/kernel/Session.ml | 27 |
8 files changed, 365 insertions, 216 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml index 9e204a9..99c4866 100644 --- a/lib/evaluators/FOL.ml +++ b/lib/evaluators/FOL.ml @@ -19,10 +19,6 @@ module Error = struct condition "unknown-attribute" "A plan projected an attribute its relation does not have" ("attribute" |=| Concepts.Value.String name) - let released_relation name = - condition "released-relation" "A plan named a relation that was already released" - ("object" |=| Concepts.Value.String name) - let malformed_program () = condition "malformed-fol-program" "A stored FOL program did not conform to what was expected. Is your database corrupted?" empty @@ -172,7 +168,7 @@ let derive ?decide relation description modes enumerate = Kernel.EphemeralRelation.instantiate ~inputs:[relation] ?decide ~modes:(fun () -> Ok modes) description - {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; program= None} + {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; pointer= None} (fun () -> enumerate relation) let rec execute plan = @@ -181,10 +177,7 @@ let rec execute plan = let* modes = modes plan in match plan with | Base relation -> - let* relation = - Protocols.Handle.copy relation - |> Option.to_result ~none:(Error.released_relation (Protocols.Handle.to_string relation)) - in + let relation = Protocols.Handle.move relation in Ok (derive ~decide:(contains relation) relation description modes enumerate) | Project (plan, _) -> let* relation = execute plan in diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml index c0ec241..fd40aff 100644 --- a/lib/kernel/EphemeralRelation.ml +++ b/lib/kernel/EphemeralRelation.ml @@ -1,11 +1,11 @@ -type program = {evaluator: string; code: Concepts.Hash.hash} +type pointer = {evaluator: string; code: Concepts.Hash.hash} type t = { name: string option; schematics: [ `Persisted of Concepts.Hash.hash | `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ]; - program: program option } + pointer: pointer option } module Error = struct open Concepts.Condition @@ -27,7 +27,7 @@ module Error = struct end module Persisted = struct - type nonrec t = {name: string; schematics: Concepts.Hash.hash; program: program} + type nonrec t = {name: string; schematics: Concepts.Hash.hash; pointer: pointer} module rec Representation : (Concepts.Encoding.Record.S with type t = t) = Concepts.Encoding.Record.Make (Body) @@ -38,7 +38,7 @@ module Persisted = struct let tag = 'E' let malformed = Error.malformed_relation - let fields {name; schematics; program= {evaluator; code}} = + let fields {name; schematics; pointer= {evaluator; code}} = let open Concepts.Encoding in [ "name", Field.string name; "schema", Value.bencode_of_hash schematics; @@ -52,15 +52,15 @@ module Persisted = struct let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in let* evaluator = Field.require_string "evaluator" fields in let* code = Bencode.field "program" fields |> fmap Value.hash_of_bencode in - Ok {name; schematics; program= {evaluator; code}} + Ok {name; schematics; pointer= {evaluator; code}} end end (* FIXME: Bring the Persisted/Temporary out to avoid using the wildcard and optionals *) let persisted = function - | {name= Some name; schematics= `Persisted schematics; program= Some program} -> - Some {Persisted.name; schematics; program} + | {name= Some name; schematics= `Persisted schematics; pointer= Some pointer} -> + Some {Persisted.name; schematics; pointer} | _ -> None class ephemeral_relation ?program ?decide description value modes enumerate inputs = @@ -112,7 +112,7 @@ let instantiate ?(inputs = []) ?program ?decide ~modes description value enumera let literal description tuples = instantiate description ~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length tuples)))]) - {name= None; schematics= `Temporary description; program= None} + {name= None; schematics= `Temporary description; pointer= None} (fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ()))) type binding = {root: Protocols.Handle.t; within: Protocols.Handle.t} @@ -143,9 +143,6 @@ let enumerate_owned relation = let asking f relation = Protocols.Handle.releasing relation (fun () -> Result.bind (Protocols.Relation.require relation) f) -(* What a program generates is known only from the relation it - returns, so reading it, asking its modes and asking for a tuple - all invoke it. *) let generated ?program ?within name description value = let invoking f () = let open Utilities.Result in @@ -162,36 +159,36 @@ let generated ?program ?within name description value = let of_program ?within description program = generated ~program ?within (Protocols.Handle.to_string program) description - {name= None; schematics= `Temporary description; program= None} + {name= None; schematics= `Temporary description; pointer= None} module Make (S : Abstract.Storage.STORAGE) = struct module SI = Storage.Make (S) module R = SubstantialRelation.Make (S) - let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t) + let restore ?program ?within ({Persisted.name; schematics; pointer} : Persisted.t) description = generated ?program ?within name description - {name= Some name; schematics= `Persisted schematics; program= Some pointer} + {name= Some name; schematics= `Persisted schematics; pointer= Some pointer} let load ?bind connection (record : Persisted.t) = let open Utilities.Result in let* description, source = SI.with_read connection (fun tx -> let* description = R.schema_of tx record.schematics in - let* code = SI.get_req tx (S.Hash record.program.code) in + let* code = SI.get_req tx (S.Hash record.pointer.code) in Ok (description, Bytes.to_string (Concepts.Blob.bytes_of_blob code)) ) in match bind with | None -> Ok (restore record description) | Some {root; within} -> - let* program = Program.load root ~evaluator:record.program.evaluator ~source in + let* program = Program.load root ~evaluator:record.pointer.evaluator ~source in Ok (restore ~program ~within record description) let store tx ~name ~evaluator ~source description = let open Utilities.Result in let* schematics = R.store_schema tx description in let* address = SI.store_blob tx (Concepts.Blob.blob_of_bytes (Bytes.of_string source)) in - let record = {Persisted.name; schematics; program= {evaluator; code= address}} in + let record = {Persisted.name; schematics; pointer= {evaluator; code= address}} in let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in Ok record diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index f01a983..e6135c6 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -180,20 +180,30 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* denials = node_of tx denials in Ok (schemas, denials) - let held (name, relation) = + let through_program ?bind relation f = + let open Utilities.Result in + match Program.image relation, bind with + | Some _, Some {EphemeralRelation.within; _} -> + let* executable = Protocols.Executable.require relation in + let* result = Protocols.Executable.invoke executable [] ~within in + Protocols.Handle.releasing result (fun () -> f result) + | _ -> f relation + + let held ?bind (name, relation) = let open Utilities.Result in Protocols.Handle.releasing relation (fun () -> - let* denial = Protocols.Relation.require relation in - let* modes = Protocols.Relation.modes denial in - if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then - Error (Error.unjudgeable name) - else - let* enumerable = Protocols.Enumerable.require relation in - let* cursor = Protocols.Enumerable.enumerate enumerable in - Protocols.Handle.releasing cursor (fun () -> - let* scan = Protocols.Cursor.require cursor in - let* first = Protocols.Cursor.next scan in - Ok (Option.to_list (Option.map (fun witness -> name, witness) first)) ) ) + through_program ?bind relation (fun relation -> + let* denial = Protocols.Relation.require relation in + let* modes = Protocols.Relation.modes denial in + if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then + Error (Error.unjudgeable name) + else + let* enumerable = Protocols.Enumerable.require relation in + let* cursor = Protocols.Enumerable.enumerate enumerable in + Protocols.Handle.releasing cursor (fun () -> + let* scan = Protocols.Cursor.require cursor in + let* first = Protocols.Cursor.next scan in + Ok (Option.to_list (Option.map (fun witness -> name, witness) first)) ) ) ) class multigroup ?bind conn value schema_tree denial_tree = object (self) @@ -222,7 +232,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct method check = let open Utilities.Result in let* named = Prototype.Directory.children (relations ?bind storage denial_tree) in - List.map held named |> Utilities.List.sequence |> Result.map List.concat + List.map (held ?bind) named |> Utilities.List.sequence |> Result.map List.concat method protocols : Protocols.Handle.protocol list = let open Utilities.Result in diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml index 2060ae6..6f308cd 100644 --- a/test/integration/Registration.ml +++ b/test/integration/Registration.ml @@ -27,16 +27,16 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = begin let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in let* relation = H.relation conn ["title"; "author"] [titled "SQL and Relational Theory"] in - let* view = - E.persist conn ~name:"shelf" ~evaluator:Evaluators.FOL.name - ~code:Evaluators.FOL.(encode (Project (Base book, BatFingerTree.singleton "title"))) + let* stored = + E.persist conn ~name:"shelf" + Evaluators.FOL.(program (Project (Base book, BatFingerTree.singleton "title"))) (BatMap.String.singleton "title" {Protocols.Schematics.domain= "string"; provenance= []}) in let* multigroup = M.make conn in let relations = Kernel.Path.("schema" @/ "default" @/ "relation" @/ this) in let* multigroup = Kernel.Path.assoc_all multigroup - [relations, "book", Some relation; relations, "shelf", Some view] + [relations, "book", Some relation; relations, "shelf", Some stored] in let* branch = B.make conn in let* branch' = @@ -51,16 +51,17 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in let* branch = Kernel.Path.lookup root stacks in let* _ = Kernel.Path.lookup branch book in - let* plan = Evaluators.FOL.(instantiate (Kernel.Path.lookup branch) (Base shelf)) in + let* plan = Evaluators.FOL.(instantiate branch (Base shelf)) in let* description = Evaluators.FOL.describe plan in - let* view = Kernel.Path.lookup branch shelf in - let* shelved = Helpers.titles view in + let* stored = Kernel.Path.lookup branch shelf in + let* shelved = Helpers.titles stored in Ok (BatMap.String.keys description |> BatList.of_enum, shelved) end |> Helpers.condition_as_failure in - check (list string) "the stored view reads the book it was defined over" ["title"] attributes; - check (list Helpers.value) "read through the branch, the stored view runs" + check (list string) "the stored program reads the book it was defined over" ["title"] + attributes; + check (list Helpers.value) "read through the branch, the stored program runs" [Concepts.Value.String "SQL and Relational Theory"] shelved diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml index a0789aa..3254258 100644 --- a/test/unit/evaluators/FOL.ml +++ b/test/unit/evaluators/FOL.ml @@ -9,22 +9,25 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = attributes= BatMap.String.empty |> BatMap.String.add "name" (Concepts.Value.String "Alaric") } - let not_a_directory () = - Concepts.Condition.condition "not-a-directory" - "A handle was expected to carry the directory protocol and did not" Concepts.Condition.empty - - let missing name = - Concepts.Condition.condition "missing" "A name was expected in the directory and was absent" - Concepts.Condition.("name" |=| Concepts.Value.String name) - let employee name age = { Concepts.Tuple.type_= "employee"; attributes= BatMap.String.of_list ["name", Concepts.Value.String name; "age", Concepts.Value.Integer age] } - (* a plan comes resolved, so it reads nothing through [within] *) - let nowhere = Kernel.Prototype.mixture [] + let named name = + { Concepts.Tuple.type_= "employee"; + attributes= BatMap.String.singleton "name" (Concepts.Value.String name) } + + let employees = Rnt.Evaluators.FOL.Base Kernel.Path.("employee" @/ this) + let names = Rnt.Evaluators.FOL.Project (employees, BatFingerTree.singleton "name") + let heading = BatMap.String.singleton "name" {Protocols.Schematics.domain= "string"; provenance= []} + let directory entries = Kernel.Prototype.(mixture [Directory.of_properties entries]) + + let eval within term = + let open Utilities.Result in + let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in + Protocols.Evaluator.eval evaluator (Rnt.Evaluators.FOL.Fol term) [] ~within let drain result = let open Utilities.Result in @@ -36,26 +39,16 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = Protocols.Handle.release result; Ok (BatFingerTree.to_list tuples) + let bindings tuples = + List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes) tuples + |> List.sort compare + let scan_a_base_relation conn = let scanned = begin let open Utilities.Result in let* employee = H.relation conn ["name"] [alaric] in - let root = - Kernel.Prototype.mixture - [ Kernel.Prototype.Directory.of_properties - ["employee", employee; "fol", Rnt.Evaluators.FOL.make ()] ] - in - let* directory = - Protocols.Directory.from root |> Option.to_result ~none:(not_a_directory ()) - in - let* found = Protocols.Directory.find directory "fol" in - let* evaluator = Option.to_result ~none:(missing "fol") found in - let* evaluator = Protocols.Evaluator.require evaluator in - let* result = - Rnt.Evaluators.FOL.(program (Base employee)) - |> Protocols.Evaluator.invoke evaluator ~within:nowhere - in + let* result = eval (directory ["employee", employee]) employees in drain result end |> Helpers.condition_as_failure @@ -71,15 +64,11 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let projected = begin let open Utilities.Result in - let* employees = + let* relation = H.relation conn ["name"; "age"] [employee "Alaric" 42; employee "Alaric" 30; employee "Brunhild" 42] in - let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = - Rnt.Evaluators.FOL.(program (Project (Base employees, BatFingerTree.singleton "name"))) - |> Protocols.Evaluator.invoke evaluator ~within:nowhere - in + let* result = eval (directory ["employee", relation]) names in drain result end |> Helpers.condition_as_failure @@ -88,25 +77,15 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (list (list (pair string Helpers.value))) "each name once, and nothing else" [["name", Concepts.Value.String "Alaric"]; ["name", Concepts.Value.String "Brunhild"]] - ( projected - |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes) - |> List.sort compare ) + (bindings projected) let instantiate_a_program conn = let projected = begin let open Utilities.Result in - let* employees = H.relation conn ["name"; "age"] [employee "Alaric" 42] in - let root = Kernel.Prototype.(mixture [Directory.of_properties ["employee", employees]]) in - let* plan = - Rnt.Evaluators.FOL.( - instantiate (Kernel.Path.lookup root) - (Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name")) ) - in - let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = - Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator ~within:nowhere - in + let* relation = H.relation conn ["name"; "age"] [employee "Alaric" 42] in + let* plan = Rnt.Evaluators.FOL.instantiate (directory ["employee", relation]) names in + let* result = Rnt.Evaluators.FOL.execute plan in drain result end |> Helpers.condition_as_failure @@ -115,14 +94,11 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (list (list (pair string Helpers.value))) "the program ran over the relation its path resolved to" [["name", Concepts.Value.String "Alaric"]] - (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)) + (bindings projected) module E = Kernel.EphemeralRelation.Make (S) - let store conn term = - E.persist conn ~name:"view" ~evaluator:Rnt.Evaluators.FOL.name - ~code:(Rnt.Evaluators.FOL.encode term) - (BatMap.String.singleton "name" {Protocols.Schematics.domain= "string"; provenance= []}) + let store conn term = E.persist conn ~name:"stored" (Rnt.Evaluators.FOL.program term) heading let namespace entries = let open Utilities.Result in @@ -141,21 +117,13 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let projected = begin let open Utilities.Result in - let* employees = H.relation conn ["name"; "age"] [employee "Alaric" 42] in - let* view = - store conn - Rnt.Evaluators.FOL.( - Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name") ) - in - let* root = namespace ["employee", employees; "view", view] in + let* relation = H.relation conn ["name"; "age"] [employee "Alaric" 42] in + let* stored = store conn names in + let* root = namespace ["employee", relation; "stored", stored] in let* plan = - Rnt.Evaluators.FOL.( - instantiate (Kernel.Path.lookup root) (Base Kernel.Path.("view" @/ this)) ) - in - let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = - Rnt.Evaluators.FOL.program plan |> Protocols.Evaluator.invoke evaluator ~within:nowhere + Rnt.Evaluators.FOL.(instantiate root (Base Kernel.Path.("stored" @/ this))) in + let* result = Rnt.Evaluators.FOL.execute plan in drain result end |> Helpers.condition_as_failure @@ -164,39 +132,36 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (list (list (pair string Helpers.value))) "the stored program ran in place of its name" [["name", Concepts.Value.String "Alaric"]] - (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)) + (bindings projected) - let run_a_stored_program_within conn = + let run_a_program_within_a_state conn = let projected = begin let open Utilities.Result in - let* employees = H.relation conn ["name"; "age"] [employee "Alaric" 42] in - let* view = - store conn - Rnt.Evaluators.FOL.( - Project (Base Kernel.Path.("employee" @/ this), BatFingerTree.singleton "name") ) - in - let* root = namespace ["employee", employees] in - let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = Protocols.Evaluator.invoke evaluator view ~within:root in - drain result + let* relation = H.relation conn ["name"; "age"] [employee "Alaric" 42] in + let* evaluators = namespace ["fol", Rnt.Evaluators.FOL.make ()] in + let* system = namespace ["evaluator", evaluators] in + let* root = namespace ["system", system] in + let* within = namespace ["employee", relation] in + Kernel.EphemeralRelation.of_program ~within heading (Rnt.Evaluators.FOL.program ~root names) + |> drain end |> Helpers.condition_as_failure in check (list (list (pair string Helpers.value))) - "the stored source read its relations where it was told to" + "the program found its evaluator under the root and read the state it was given" [["name", Concepts.Value.String "Alaric"]] - (projected |> List.map (fun tuple -> BatMap.String.bindings tuple.Concepts.Tuple.attributes)) + (bindings projected) let refuse_a_program_that_reads_itself conn = let expanded = begin let open Utilities.Result in - let* view = store conn Rnt.Evaluators.FOL.(Base Kernel.Path.("view" @/ this)) in - let* root = namespace ["view", view] in - Rnt.Evaluators.FOL.( - instantiate (Kernel.Path.lookup root) (Base Kernel.Path.("view" @/ this)) ) + let stored_path = Kernel.Path.("stored" @/ this) in + let* stored = store conn (Rnt.Evaluators.FOL.Base stored_path) in + let* root = namespace ["stored", stored] in + Rnt.Evaluators.FOL.(instantiate root (Base stored_path)) end in check bool "the expansion stopped at the cycle" true @@ -205,8 +170,42 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = BatString.starts_with (Concepts.Condition.to_string_hum condition) "cyclic-program" | Ok _ -> false ) - let pull_one_tuple_at_a_time () = - let produced = ref 0 and closed = ref false in + let shape modes = + List.map + (fun {Concepts.Mode.bound; yields} -> + BatSet.String.elements bound, Concepts.Cardinality.to_string yields ) + modes + + let a_projection_keeps_the_modes_it_can_bind conn = + let ask term f = + begin + let open Utilities.Result in + let* relation = + H.relation conn ["name"; "age"] [employee "Alaric" 42; employee "Brunhild" 30] + in + let* result = eval (directory ["employee", relation]) term in + Protocols.Handle.releasing result (fun () -> + Result.bind (Protocols.Relation.require result) f ) + end + |> Helpers.condition_as_failure + in + let modes term = shape (ask term Protocols.Relation.modes) in + let holds term tuple = ask term (fun r -> Protocols.Relation.contains r tuple) in + check + (list (pair (list string) string)) + "a base relation keeps the lookup by hash" + [[], "finite"; ["age"; "name"], "bounded(1)"] + (modes employees); + check + (list (pair (list string) string)) + "its projection keeps only what a projected tuple can bind" + [[], "finite"] + (modes names); + check bool "the base decides by its own test" true (holds employees (employee "Alaric" 42)); + check bool "the projection decides by reading" true (holds names (named "Alaric")); + check bool "and refuses a stranger" false (holds names (named "Gunther")) + + let counter ?(produced = ref 0) ?(closed = ref false) () = let description = BatMap.String.singleton "value" {Protocols.Schematics.domain= "integer"; provenance= []} in @@ -217,19 +216,19 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = attributes= BatMap.String.singleton "value" (Concepts.Value.Integer n) }; count ~yield (n + 1) in - let source = - Kernel.EphemeralRelation.instantiate description - {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; program= None} - (fun () -> Ok (Kernel.Generator.cursor_of ~finally:(fun () -> closed := true) (count 0))) - in + Kernel.EphemeralRelation.instantiate description + ~modes:(fun () -> Ok [Concepts.(Mode.mode [] Cardinality.Countable)]) + {Kernel.EphemeralRelation.name= None; schematics= `Temporary description; pointer= None} + (fun () -> Ok (Kernel.Generator.cursor_of ~finally:(fun () -> closed := true) (count 0))) + + let values source = Rnt.Evaluators.FOL.(execute (Project (Base source, BatFingerTree.singleton "value"))) + + let pull_one_tuple_at_a_time () = + let produced = ref 0 and closed = ref false in let first = begin let open Utilities.Result in - let* evaluator = Protocols.Evaluator.require (Rnt.Evaluators.FOL.make ()) in - let* result = - Rnt.Evaluators.FOL.(program (Project (Base source, BatFingerTree.singleton "value"))) - |> Protocols.Evaluator.invoke evaluator ~within:nowhere - in + let* result = values (counter ~produced ~closed ()) in let* enumerable = Protocols.Enumerable.require result in let* cursor = Protocols.Enumerable.enumerate enumerable in let* scan = Protocols.Cursor.require cursor in @@ -242,6 +241,48 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = check int "the source produced only that tuple" 1 !produced; check bool "and was closed with its consumer" true !closed + let an_endless_projection_cannot_decide () = + let asked = + begin + let open Utilities.Result in + let* result = values (counter ()) in + let* relation = Protocols.Relation.require result in + Protocols.Relation.contains relation + { Concepts.Tuple.type_= "counter"; + attributes= BatMap.String.singleton "value" (Concepts.Value.Integer 7) } + end + in + check bool "it fails as undecidable instead of reading without end" true + ( match asked with + | Error condition -> + BatString.starts_with (Concepts.Condition.to_string_hum condition) + "undecidable-membership" + | Ok _ -> false ) + + let a_result_owns_the_relations_of_its_plan () = + let released = ref false in + let tracker = + Protocols.Handle.make + object + method reference = true + method release = released := true + method is_managed = false + method hash = Concepts.Hash.hash_of_int 0 + method to_string = "tracker" + method protocols : Protocols.Handle.protocol list = [] + end + in + let relation = + Kernel.EphemeralRelation.instantiate ~inputs:[tracker] heading + ~modes:(fun () -> Ok []) + {Kernel.EphemeralRelation.name= None; schematics= `Temporary heading; pointer= None} + (fun () -> Ok (Kernel.Generator.cursor_of (fun ~yield:_ -> Ok ()))) + in + let result = Rnt.Evaluators.FOL.(execute (Base relation)) |> Helpers.condition_as_failure in + check bool "the relation in the plan lives as long as the result" false !released; + Protocols.Handle.release result; + check bool "and is released with it" true !released + let suite = ( "evaluators/fol", [ test_case "scan-a-base-relation" `Quick (H.with_connection scan_a_base_relation "fol-test"); @@ -251,11 +292,16 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = (H.with_connection instantiate_a_program "fol-test"); test_case "expand-a-stored-program" `Quick (H.with_connection expand_a_stored_program "fol-test"); - test_case "run-a-stored-program-within" `Quick - (H.with_connection run_a_stored_program_within "fol-test"); + test_case "run-a-program-within-a-state" `Quick + (H.with_connection run_a_program_within_a_state "fol-test"); test_case "refuse-a-program-that-reads-itself" `Quick (H.with_connection refuse_a_program_that_reads_itself "fol-test"); - test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time ] ) + test_case "a-projection-keeps-the-modes-it-can-bind" `Quick + (H.with_connection a_projection_keeps_the_modes_it_can_bind "fol-test"); + test_case "pull-one-tuple-at-a-time" `Quick pull_one_tuple_at_a_time; + test_case "an-endless-projection-cannot-decide" `Quick an_endless_projection_cannot_decide; + test_case "a-result-owns-the-relations-of-its-plan" `Quick + a_result_owns_the_relations_of_its_plan ] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml index ebce298..606d8b7 100644 --- a/test/unit/kernel/Branch.ml +++ b/test/unit/kernel/Branch.ml @@ -11,23 +11,19 @@ let shelf = K.Scope.path library "shelf" let s v = C.Value.String v let title = BatMap.String.singleton "title" {P.Schematics.domain= "string"; provenance= []} -let books titles = - K.EphemeralRelation.literal title - (List.map - (fun t -> {C.Tuple.type_= "book"; attributes= BatMap.String.singleton "title" (s t)}) - titles ) +let book t = {C.Tuple.type_= "book"; attributes= BatMap.String.singleton "title" (s t)} +let books titles = K.EphemeralRelation.literal title (List.map book titles) let titles relation = ok (Helpers.titles relation) let read root path = titles (ok (K.Path.lookup root path)) (* shelf is a stored FOL program reading book where it is stored *) let shelved = - K.Source.view ~language:"fol" ~heading:title - ( Rnt.Evaluators.FOL.(encode (Base (K.Scope.path library "book"))) - |> C.Blob.bytes_of_blob - |> Bytes.to_string ) + K.EphemeralRelation.of_program title + Rnt.Evaluators.FOL.(program (Base (K.Scope.path library "book"))) -let publish root changes = ok (K.Scope.publish root ~branch:"master" ~home:library changes) +let publish ?denials root changes = + ok (K.Scope.publish ?denials root ~branch:"master" ~home:library changes) let fresh books' = let root = ok (Rnt.Scratch.root ()) in @@ -113,55 +109,162 @@ let a_scope_reads_names_from_its_home () = check (option string) "but not another relation's" None (K.Scope.attribute library "book" "shelf:title") -(* A toy language answers a stored relation with its own name, and a run - with the source it was given. *) -let a_stored_relation_is_viewed_and_a_program_run () = +type K.Program.kind += Title of string | Endless | Shout of K.Path.t + +let endless () = + K.EphemeralRelation.instantiate title + ~modes:(fun () -> Ok [C.(Mode.mode [] Cardinality.Countable)]) + {K.EphemeralRelation.name= None; schematics= `Temporary title; pointer= None} + (fun () -> + Ok + (K.Generator.cursor_of (fun ~yield -> + let rec from n = yield (book (string_of_int n)); from (n + 1) in + from 0 ) ) ) + +(* A toy language: "endless" answers titles without end, "shout r" the + titles of relation r in capitals, and anything else itself as a title. *) +let parse source = + match String.split_on_char ' ' source with + | ["endless"] -> Endless + | ["shout"; name] -> Shout (K.Scope.path library name) + | _ -> Title source + +let shout within path = + let open Rnt.Utilities.Result in + let* relation = K.Path.lookup within path in + let* heard = P.Handle.releasing relation (fun () -> Helpers.titles relation) in + Ok + (books + (List.filter_map + (function C.Value.String t -> Some (String.uppercase_ascii t) | _ -> None) + heard ) ) + +let toy ?(evaluations = ref 0) () = + P.Handle.make + object (self) + inherit K.Lifecycle.null + inherit K.Identity.of_id + method to_string = "toy-evaluator" + method parse source = Ok (parse source) + + method eval kind _ ~within = + incr evaluations; + match kind with + | Title text -> Ok (books [text]) + | Endless -> Ok (endless ()) + | Shout path -> shout within path + | _ -> Error (C.Condition.condition "foreign-program" "Not a toy program" C.Condition.empty) + + method protocols : P.Handle.protocol list = [P.Evaluator.make self] + end + +let with_toys ?evaluations root = + ignore (ok (K.Initialization.mount root "toys")); + ignore + (ok + (K.Path.update root K.Path.("toys" @/ "evaluator" @/ this) "toy" None + (Some (toy ?evaluations ())) ) ) + +let toy_program ?root evaluator source = K.Program.make ?root ~evaluator ~source (parse source) + +let run root program = + Result.bind (P.Executable.require program) (fun executable -> + P.Executable.invoke executable [] ~within:root ) + +let a_program_runs_through_the_evaluator_it_names () = let root = fresh ["Codd"] in - let answer text = Ok (books [text]) in - let toy = - K.Source.evaluator ~language:"toy" - ~view:(fun ~within:_ ~name source -> answer (name ^ " of " ^ source)) - (fun ~within:_ source -> answer source) - in - let _ = ok (K.Initialization.mount root "toys") in - ok (K.Source.register root ~scope:"toys" ~language:"toy" toy); - publish root ["named", Some (K.Source.view ~language:"toys:toy" ~heading:title "this")]; - check (list Helpers.value) "read from the branch, the view is asked for it by name" - [s "named of this"] + with_toys root; + publish root + ["named", Some (K.EphemeralRelation.of_program title (toy_program "toys:toy" "this"))]; + check (list Helpers.value) "stored in a branch and read back, it runs" + [s "this"] (read root (under master (K.Scope.path library "named"))); - check (list Helpers.value) "run, the program is just run" + check (list Helpers.value) "run directly, it runs" [s "that"] - (titles (ok (K.Source.run root ~language:"toys:toy" ~within:root "that"))); + (titles (ok (run root (toy_program ~root "toys:toy" "that")))); check bool "an unqualified name is the system's" true - (Result.is_error (K.Source.run root ~language:"toy" ~within:root "that")) + (Result.is_error (run root (toy_program ~root "toy" "that"))) + +(* shelf, from fresh, is a FOL program reading book *) +let evaluators_read_each_other () = + let root = fresh ["Codd"] in + with_toys root; + let stored name program = name, Some (K.EphemeralRelation.of_program title program) in + publish root + [ stored "toy-shelf" (toy_program "toys:toy" "Date"); + stored "fol-over-toy" Rnt.Evaluators.FOL.(program (Base (K.Scope.path library "toy-shelf"))); + stored "toy-over-fol" (toy_program "toys:toy" "shout shelf") ]; + check (list Helpers.value) "FOL reads the relation a toy program generates" + [s "Date"] + (read root (under master (K.Scope.path library "fol-over-toy"))); + check (list Helpers.value) "a toy program shouts the relation a FOL program generates" + [s "CODD"] + (read root (under master (K.Scope.path library "toy-over-fol"))) (* shelf, stored as a denial, says no book may be shelved *) -let a_head_moves_only_to_a_valid_state () = +let denied state = List.map fst (ok (P.Admission.check (ok (P.Admission.require state)))) +let no_books = "\\multigroup\\library\\denial\\no-books" + +let a_head_moves_only_to_an_admitted_state () = let root = fresh [] in - publish root ["denial:no-books", Some shelved]; + publish root ~denials:["no-books", Some shelved] []; let head = ok (K.Path.lookup root master) in + check (list string) "the head is admitted" [] (denied head); let proposed = - ok - (K.Path.assoc_all head - [ ( K.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ this), - "book", - Some (books ["Codd"]) ) ] ) + ok (K.Path.assoc_all head [K.Scope.relations library, "book", Some (books ["Codd"])]) in - check bool "a state with a book is judged invalid without landing" true - (Result.is_error (K.Denial.check proposed)); + check (list string) "a state with a book is not, and says by which denial" [no_books] + (denied proposed); check bool "publishing it is refused" true (Result.is_error (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Codd"])]) ); check bool "and the head stays" true (C.Hash.hash_equals (address head) (address (ok (K.Path.lookup root master)))) +(* a denial of multigroup audit reads library's books *) +let a_rule_spans_multigroups () = + let root = fresh [] in + publish root ~denials:["audit:no-books", Some shelved] ["loan", Some (books ["Codd"])]; + check bool "a commit to library is judged by audit" true + (Result.is_error + (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Codd"])]) ); + check (list Helpers.value) "one audit's denial does not mind lands" + [s "Codd"] + (read root (under master (K.Scope.path library "loan"))) + +let a_denial_without_end_cannot_be_installed () = + let root = fresh [] in + with_toys root; + let endless = K.EphemeralRelation.of_program title (toy_program "toys:toy" "endless") in + match K.Scope.publish root ~branch:"master" ~home:library ~denials:["endless", Some endless] [] with + | Ok () -> fail "a denial without end was installed" + | Error condition -> + check bool "the state holding it cannot be judged" true + (BatString.starts_with (C.Condition.to_string_hum condition) "unjudgeable-denial") + +let a_denial_program_runs_once_per_judgement () = + let root = fresh [] in + let evaluations = ref 0 in + with_toys ~evaluations root; + let dated = K.EphemeralRelation.of_program title (toy_program "toys:toy" "Date") in + check bool "a denial holding a book refuses the commit" true + (Result.is_error + (K.Scope.publish root ~branch:"master" ~home:library ~denials:["dated", Some dated] []) ); + check int "and its program ran once to judge it" 1 !evaluations + let suites () = [ ( "kernel/branch", [ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state; test_case "a-batch-is-one-successor" `Quick a_batch_is_one_successor; test_case "unbinding-removes-a-relation" `Quick unbinding_removes_a_relation; test_case "a-scope-reads-names-from-its-home" `Quick a_scope_reads_names_from_its_home; - test_case "a-stored-relation-is-viewed-and-a-program-run" `Quick - a_stored_relation_is_viewed_and_a_program_run; - test_case "a-head-moves-only-to-a-valid-state" `Quick a_head_moves_only_to_a_valid_state ] ) - ] + test_case "a-program-runs-through-the-evaluator-it-names" `Quick + a_program_runs_through_the_evaluator_it_names; + test_case "evaluators-read-each-other" `Quick evaluators_read_each_other; + test_case "a-head-moves-only-to-an-admitted-state" `Quick + a_head_moves_only_to_an_admitted_state; + test_case "a-rule-spans-multigroups" `Quick a_rule_spans_multigroups; + test_case "a-denial-without-end-cannot-be-installed" `Quick + a_denial_without_end_cannot_be_installed; + test_case "a-denial-program-runs-once-per-judgement" `Quick + a_denial_program_runs_once_per_judgement ] ) ] diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml index 7f113ef..c9742f0 100644 --- a/test/unit/kernel/EphemeralRelation.ml +++ b/test/unit/kernel/EphemeralRelation.ml @@ -12,11 +12,21 @@ let description = { Protocols.Schematics.domain= "integer"; provenance= [{Protocols.Schematics.source= ["example"]; attribute= "value"}] } -let temporary = {Ephemeral.name= None; schematics= `Temporary description; program= None} +let temporary = {Ephemeral.name= None; schematics= `Temporary description; pointer= None} let over ?inputs ?(value = temporary) members = - Ephemeral.instantiate ?inputs description value (fun () -> - Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ())) ) + Ephemeral.instantiate ?inputs description value + ~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length members)))]) + (fun () -> Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ()))) + +let endless () = + Ephemeral.instantiate description temporary + ~modes:(fun () -> Ok [Concepts.(Mode.mode [] Cardinality.Countable)]) + (fun () -> + Ok + (Rnt.Kernel.Generator.cursor_of (fun ~yield -> + let rec from n = yield (member n); from (n + 1) in + from 0 ) ) ) let values tuples = BatFingerTree.to_list tuples @@ -55,6 +65,17 @@ let decides_membership () = check bool "a member is held" true holds; check bool "a stranger is refused" false rejects +let refuses_to_scan_without_end () = + match Protocols.Relation.require (endless ()) with + | Error condition -> fail (Concepts.Condition.to_string_hum condition) + | Ok relation -> ( + match Protocols.Relation.contains relation (member 9) with + | Error condition -> + check bool "it fails as undecidable instead of scanning" true + (BatString.starts_with (Concepts.Condition.to_string_hum condition) + "undecidable-membership" ) + | Ok _ -> fail "an endless relation with no test decided membership" ) + let describes_itself () = let described = begin @@ -83,7 +104,7 @@ let addressed_once_persisted () = let persisted code = { Ephemeral.name= Some "example"; schematics= `Persisted (Concepts.Hash.hash_of_int 1); - program= Some {Ephemeral.evaluator= "fol"; code= Concepts.Hash.hash_of_int code} } + pointer= Some {Ephemeral.evaluator= "fol"; code= Concepts.Hash.hash_of_int code} } in let address value = Protocols.Addressable.from (over ~value []) |> Option.map Protocols.Addressable.address @@ -97,9 +118,9 @@ let releasing_releases_its_inputs () = let released = ref false in let input = object - method reference = true - method release = released := true - method hash = Concepts.Hash.hash_of_int 0 + inherit Rnt.Kernel.Lifecycle.null + inherit Rnt.Kernel.Identity.of_id + method! release = released := true method to_string = "input" method protocols : Protocols.Handle.protocol list = [] end @@ -113,6 +134,7 @@ let suites () = [ ( "kernel/ephemeral-relation", [ test_case "enumerates-every-member" `Quick enumerates_every_member; test_case "decides-membership" `Quick decides_membership; + test_case "refuses-to-scan-without-end" `Quick refuses_to_scan_without_end; test_case "describes-itself" `Quick describes_itself; test_case "addressed-once-persisted" `Quick addressed_once_persisted; test_case "releasing-releases-its-inputs" `Quick releasing_releases_its_inputs ] ) ] diff --git a/test/unit/kernel/Session.ml b/test/unit/kernel/Session.ml index 79ad5a2..edb22c4 100644 --- a/test/unit/kernel/Session.ml +++ b/test/unit/kernel/Session.ml @@ -25,7 +25,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let* _ = update root ("system" @/ "branch" @/ this) "client" None (Some branch) in let* tip = address branch in let session = Session.make conn {Protocols.Session.snapshot= tip} in - let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in + let* _ = update root ("system" @/ "session" @/ this) "client" None (Protocols.Handle.copy session) in let library = "system" @/ "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this in @@ -55,32 +55,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = check bool "the session reconstructs the pinned branch" true pinned; check bool "the session refuses derivation through it" true refused - let single_handle conn = - let refused, reacquired = - begin - let open Utilities.Result in - let open Rnt.Kernel.Path in - let* root = I.initialize conn in - let* branch = B.make conn in - let* tip = address branch in - let session = Session.make conn {Protocols.Session.snapshot= tip} in - let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in - let client = "system" @/ "session" @/ "client" @/ this in - let* _ = lookup root ("system" @/ "session" @/ "client" @/ "branch" @/ this) in - let* held = lookup root client in - let refused = finds root client in - Protocols.Handle.release held; - Ok (refused, finds root client) - end - |> Helpers.condition_as_failure - in - check bool "a second handle to the session is refused" false refused; - check bool "releasing the handle frees the session" true reacquired - let suite = ( "kernel/session", - [ test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test"); - test_case "single-handle" `Quick (H.with_connection single_handle "session-single-test") ] ) + [test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test")] ) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) |