diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/Multigroup.ml | 22 | ||||
| -rw-r--r-- | test/Helpers.ml | 4 | ||||
| -rw-r--r-- | test/integration/Registration.ml | 38 | ||||
| -rw-r--r-- | test/unit/kernel/EphemeralRelation.ml | 24 |
4 files changed, 74 insertions, 14 deletions
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml index 01675f0..1417a65 100644 --- a/lib/kernel/Multigroup.ml +++ b/lib/kernel/Multigroup.ml @@ -79,9 +79,31 @@ module Make (S : Abstract.Storage.STORAGE) = struct val storage = conn val node = node (* FIXME: see the comment on Branch.ml *) + (* TODO: Add later to the lifecycle management, accounting for + derived instances. Callers must release the previous handle + when done with it so its instance can be cleaned up after the + last reference is released. *) + method deriving multigroup' = + let open Utilities.Result in + let* node' = + SI.with_transaction storage (fun tx -> + let* _ = SI.store_blob tx (Representation.to_blob multigroup') in + RelationM.find tx multigroup'.relations + |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) ) + in + new multigroup storage multigroup' node' |> Protocols.Handle.make |> Result.ok + method protocols : Protocols.Handle.protocol list = + let open Utilities.Result in Protocols. [ Addressable.make self; + Prototype.Associative.( + of_properties + [ ( "relation", + update_only (fun node' -> + Handle.require Addressable.from node' + |> Result.map Addressable.address + |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] ); Prototype.Directory.of_properties [ ( "relation", Prototype.mixture_of node (fun make node -> diff --git a/test/Helpers.ml b/test/Helpers.ml index 7f65007..f812a3a 100644 --- a/test/Helpers.ml +++ b/test/Helpers.ml @@ -51,7 +51,9 @@ module Storage = struct SR.TupleSet.insert tx (Concepts.Tuple.hash tuple) tuple node ) (Ok SR.TupleSet.empty) tuples in - Ok {SR.schematics; tuples= SR.TupleSet.hash_of node} ) + let relation = {SR.schematics; tuples= SR.TupleSet.hash_of node} in + let* _ = SI.store_blob tx (SR.encode relation) in + Ok relation ) in SR.load conn value diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml index 60f1690..693435b 100644 --- a/test/integration/Registration.ml +++ b/test/integration/Registration.ml @@ -6,12 +6,28 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = module I = Kernel.Initialization.Make (S) module B = Kernel.Branch.Make (S) module M = Kernel.Multigroup.Make (S) + module R = Kernel.SubstantialRelation.Make (S) + module E = Kernel.EphemeralRelation.Make (S) + + let book = Kernel.Path.("multigroup" @/ "library" @/ "relation" @/ "book" @/ this) + let shelf = Kernel.Path.("multigroup" @/ "library" @/ "relation" @/ "shelf" @/ this) let run conn = let open Utilities.Result in begin let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in let* multigroup = M.make conn in + let* schematics = H.SI.with_transaction conn (fun tx -> H.store_schema tx ["title"]) in + let* relation = R.instantiate conn ~schematics in + let* multigroup = + Kernel.Path.(assoc multigroup ("relation" @/ this) "book" (Some relation)) + in + let* view = + E.persist conn ~name:"shelf" ~evaluator:Evaluators.FOL.name + ~code:Evaluators.FOL.(encode (Project (Base book, BatFingerTree.singleton "title"))) + (BatMap.String.singleton "title" {Protocols.Schematics.domain= "string"; provenance= []}) + in + let* multigroup = Kernel.Path.(assoc multigroup ("relation" @/ this) "shelf" (Some view)) in let* branch = B.make conn in let* branch' = Kernel.Path.(assoc branch ("multigroup" @/ this) "library" (Some multigroup)) @@ -20,15 +36,19 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = end |> Helpers.condition_as_failure |> ignore; - begin - let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in - let* _ = - Kernel.Path.(lookup root ("branch" @/ "master" @/ "multigroup" @/ "library" @/ this)) - in - let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in - Ok () - end - |> Helpers.condition_as_failure + let attributes = + begin + let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in + let* branch = Kernel.Path.(lookup root ("branch" @/ "master" @/ this)) in + let* _ = Kernel.Path.lookup branch book in + let* _ = Kernel.Path.(lookup root ("evaluator" @/ "fol" @/ this)) in + let* plan = Evaluators.FOL.(instantiate (Kernel.Path.lookup branch) (Base shelf)) in + let* description = Evaluators.FOL.describe plan in + Ok (BatMap.String.keys description |> BatList.of_enum) + end + |> Helpers.condition_as_failure + in + check (list string) "the stored view reads the book it was defined over" ["title"] attributes let suite = ( "registration", diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml index 95ce56d..7f113ef 100644 --- a/test/unit/kernel/EphemeralRelation.ml +++ b/test/unit/kernel/EphemeralRelation.ml @@ -12,10 +12,11 @@ let description = { Protocols.Schematics.domain= "integer"; provenance= [{Protocols.Schematics.source= ["example"]; attribute= "value"}] } -let over ?inputs members = - Ephemeral.instantiate ?inputs description - {Ephemeral.schematics= `Temporary description} - (fun () -> Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ()))) +let temporary = {Ephemeral.name= None; schematics= `Temporary description; program= 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 ())) ) let values tuples = BatFingerTree.to_list tuples @@ -78,6 +79,20 @@ let describes_itself () = ^ origin.Protocols.Schematics.attribute ) ) ) | _ -> fail "an ephemeral relation describes itself as a relation" +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} } + in + let address value = + Protocols.Addressable.from (over ~value []) |> Option.map Protocols.Addressable.address + in + check bool "a temporary relation has no address" true (Option.is_none (address temporary)); + check bool "a persisted one has" true (Option.is_some (address (persisted 2))); + check bool "and its program is part of it" false + (Option.equal Concepts.Hash.hash_equals (address (persisted 2)) (address (persisted 3))) + let releasing_releases_its_inputs () = let released = ref false in let input = @@ -99,4 +114,5 @@ let suites () = [ test_case "enumerates-every-member" `Quick enumerates_every_member; test_case "decides-membership" `Quick decides_membership; 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 ] ) ] |