diff options
30 files changed, 625 insertions, 61 deletions
@@ -1,2 +1,3 @@ .direnv -_build
\ No newline at end of file +_build +vcpkg_installed
\ No newline at end of file diff --git a/lib/abstract/Storage.ml b/lib/abstract/Storage.ml index e921be9..afd1a3c 100644 --- a/lib/abstract/Storage.ml +++ b/lib/abstract/Storage.ml @@ -6,9 +6,15 @@ module type STORAGE = sig val connect : Concepts.Configuration.term -> (connection, Concepts.Condition.condition) result + (** close `connection`, after which none of its transactions may be used *) + val disconnect : connection -> unit + (** begin a transaction within `connection` *) val start : connection -> (transaction, Concepts.Condition.condition) result + (** begin a read-only transaction, which may be held alongside others *) + val start_read : connection -> (transaction, Concepts.Condition.condition) result + (** `commit` the current transaction *) val commit : transaction -> (unit, Concepts.Condition.condition) result diff --git a/lib/backend/storage/LMDB.ml b/lib/backend/storage/LMDB.ml index be23128..e364b6a 100644 --- a/lib/backend/storage/LMDB.ml +++ b/lib/backend/storage/LMDB.ml @@ -118,6 +118,11 @@ module C = struct module Errors = struct let mdb_notfound = -30798 end + + module Flags = struct + let mdb_notls = Unsigned.UInt.of_int 0x200000 + let mdb_rdonly = Unsigned.UInt.of_int 0x20000 + end end module Error = struct @@ -147,7 +152,9 @@ let connect (c : Concepts.Configuration.term) = let* path, mode = parse c in begin let* env = C.mdb_env_create' () in - match C.mdb_env_open env path Unsigned.UInt.zero (PosixTypes.Mode.of_int mode) with + (* NOTLS ties readers to transactions rather than threads, so one + thread can hold several read transactions (nested cursors). *) + match C.mdb_env_open env path C.Flags.mdb_notls (PosixTypes.Mode.of_int mode) with | Error x -> C.mdb_env_close env; Error x | Ok () -> let* tx = C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero in @@ -160,11 +167,16 @@ let connect (c : Concepts.Configuration.term) = Concepts.Condition.( complement ("path" |=| Concepts.Value.String path & "mode" |=| Concepts.Value.Integer mode) ) -let start ({env; dbi} : connection) = - C.mdb_txn_begin' env C.null_txn Unsigned.UInt.zero +let disconnect ({env; _} : connection) = C.mdb_env_close env + +let begin_with flags ({env; dbi} : connection) = + C.mdb_txn_begin' env C.null_txn flags |> Result.map (fun tx -> {tx; dbi; active = true;}) |> Result.map_error Error.lmdb_error +let start = begin_with Unsigned.UInt.zero +let start_read = begin_with C.Flags.mdb_rdonly + let commit transaction = if not transaction.active then Error Error.closed_transaction else begin diff --git a/lib/concepts/Cardinality.ml b/lib/concepts/Cardinality.ml new file mode 100644 index 0000000..d878aa9 --- /dev/null +++ b/lib/concepts/Cardinality.ml @@ -0,0 +1,20 @@ +type t = Empty | Bounded of int | Finite | Countable + +let bounded n = if n <= 0 then Empty else Bounded n +let rank = function Empty -> 0 | Bounded _ -> 1 | Finite -> 2 | Countable -> 3 + +let compare a b = + match a, b with + | Bounded n, Bounded m -> Utilities.Ordering.of_int (Int.compare n m) + | _ -> Utilities.Ordering.of_int (Int.compare (rank a) (rank b)) + +let equal a b = compare a b = Utilities.Ordering.Equal +let leq a b = compare a b <> Utilities.Ordering.Greater +let meet a b = if leq a b then a else b +let exhaustible = function Countable -> false | Empty | Bounded _ | Finite -> true + +let to_string = function + | Empty -> "empty" + | Bounded n -> Printf.sprintf "bounded(%d)" n + | Finite -> "finite" + | Countable -> "countable" diff --git a/lib/concepts/Cardinality.mli b/lib/concepts/Cardinality.mli new file mode 100644 index 0000000..d345bce --- /dev/null +++ b/lib/concepts/Cardinality.mli @@ -0,0 +1,9 @@ +type t = Empty | Bounded of int | Finite | Countable + +val bounded : int -> t +val compare : t -> t -> Utilities.Ordering.t +val equal : t -> t -> bool +val leq : t -> t -> bool +val meet : t -> t -> t +val exhaustible : t -> bool +val to_string : t -> string diff --git a/lib/concepts/Mode.ml b/lib/concepts/Mode.ml new file mode 100644 index 0000000..b7aa814 --- /dev/null +++ b/lib/concepts/Mode.ml @@ -0,0 +1,30 @@ +type attribute = string +type attributes = BatSet.String.t +type affordance = Decides | Generates of Cardinality.t +type mode = {bound: attributes; affords: affordance} +type t = mode list + +let attributes_of_list = BatSet.String.of_list +let attributes_of_map map = BatMap.String.keys map |> BatSet.String.of_enum +let decides_when bound = {bound= attributes_of_list bound; affords= Decides} +let enumerable cardinality = {bound= BatSet.String.empty; affords= Generates cardinality} +let of_list modes = modes + +let generation declaration bound = + List.fold_left + (fun tightest {bound= declared; affords} -> + match affords with + | Generates cardinality when BatSet.String.subset declared bound -> + Some (Option.fold ~none:cardinality ~some:(Cardinality.meet cardinality) tightest) + | Generates _ | Decides -> tightest ) + None declaration + +let exhaustible declaration bound = + Option.fold ~none:false ~some:Cardinality.exhaustible (generation declaration bound) + +let decision declaration bound = + exhaustible declaration bound + || List.exists + (fun {bound= declared; affords} -> + match affords with Decides -> BatSet.String.equal declared bound | Generates _ -> false ) + declaration diff --git a/lib/concepts/Mode.mli b/lib/concepts/Mode.mli new file mode 100644 index 0000000..6a906d1 --- /dev/null +++ b/lib/concepts/Mode.mli @@ -0,0 +1,27 @@ +type attribute = string +type attributes = BatSet.String.t + +(** what asking a relation under a given set of bound attributes + affords. The answer is to whether anything satisfies the binding, + or the bindings of the attributes left free together with the + class of what is produced. *) +type affordance = Decides | Generates of Cardinality.t + +type mode = {bound: attributes; affords: affordance} +type t + +val attributes_of_list : attribute list -> attributes +val attributes_of_map : 'a BatMap.String.t -> attributes +val decides_when : attribute list -> mode +val enumerable : Cardinality.t -> mode +val of_list : mode list -> t + +(** the tightest class declared for generating under [bound]. A mode + declared for fewer bound attributes applies to more, since the + attributes left free are then fewer and no more numerous. *) +val generation : t -> attributes -> Cardinality.t option + +val exhaustible : t -> attributes -> bool + +(** declared outright, or implied by a generation that can be exhausted. *) +val decision : t -> attributes -> bool diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml new file mode 100644 index 0000000..b403e13 --- /dev/null +++ b/lib/kernel/EphemeralRelation.ml @@ -0,0 +1,73 @@ +module type DERIVATION = sig + type plan + + val identity : plan -> Concepts.Hash.hash + + val describe : + plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result + + val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result + + val generate : + plan -> + Protocols.Generative.binding -> + (Protocols.Handle.t, Concepts.Condition.condition) result +end + +module Make (D : DERIVATION) = struct + let pinned_tag = "rnt/pinned/1" + + let identity ?pinned plan = + let derivation = D.identity plan in + match pinned with + | None -> derivation + | Some branch -> + pinned_tag ^ Concepts.Hash.to_raw_string derivation ^ Concepts.Hash.to_raw_string branch + |> Bytes.of_string + |> Concepts.Hash.hash_of_bytes + + class ephemeral (plan : D.plan) address declaration description edges = + object (self) + inherit Lifecycle.counted + inherit Protocols.Generative.membership + val heading = Concepts.Mode.attributes_of_map description + method destroy = List.iter Protocols.Handle.release edges + method predicate = Ok None + method local_constraints = Ok None + method modes = Ok declaration + + (* A cursor holds a reference to its relation, so the edges it reads + outlive a release of the relation that produced it. *) + method generate binding = + D.generate plan binding + |> Result.map (fun cursor -> + new Lifecycle.retaining cursor (self :> Lifecycle.lifecycle) |> Protocols.Handle.make ) + + method enumerate = self#generate Protocols.Generative.nothing + method describe () = Ok (Protocols.Schematics.Relation description) + + method protocols : Protocols.Handle.protocol list = + let carried = + [ Protocols.Relation.make self; + Protocols.Schematics.make self; + Protocols.Generative.make self ] + in + if Concepts.Mode.exhaustible declaration BatSet.String.empty then + Protocols.Enumerable.make self :: carried + else carried + + method hash : Concepts.Hash.hash = address + end + + let derive ?pinned ?(edges = []) plan = + let open Utilities.Result in + let derived = + let* declaration = D.modes plan in + let* description = D.describe plan in + Ok + ( new ephemeral plan (identity ?pinned plan) declaration description edges + |> Protocols.Handle.make ) + in + Result.iter_error (fun _ -> List.iter Protocols.Handle.release edges) derived; + derived +end diff --git a/lib/kernel/EphemeralRelation.mli b/lib/kernel/EphemeralRelation.mli new file mode 100644 index 0000000..d082394 --- /dev/null +++ b/lib/kernel/EphemeralRelation.mli @@ -0,0 +1,36 @@ +module type DERIVATION = sig + type plan + + (** the hash of the plan, taken over the branch-local names of its + inputs rather than over their content addresses. The idea is to + have the same expression denote one object on every branch and + at every point in time. *) + val identity : plan -> Concepts.Hash.hash + + val describe : + plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result + + val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result + + val generate : + plan -> + Protocols.Generative.binding -> + (Protocols.Handle.t, Concepts.Condition.condition) result +end + +module Make (D : DERIVATION) : sig + (** unpinned, the identity of the derivation itself; pinned to a + branch commit, the identity of that derivation against one + reconstructible state, which is the only form for which equal + identity implies equal extension. *) + val identity : ?pinned:Concepts.Hash.hash -> D.plan -> Concepts.Hash.hash + + (** edges are the handles the derivation reads, which are released + when the relation is also. Rejection of a derivation surfaces + here instead of when a cursor is being drained. *) + val derive : + ?pinned:Concepts.Hash.hash -> + ?edges:Protocols.Handle.t list -> + D.plan -> + (Protocols.Handle.t, Concepts.Condition.condition) result +end diff --git a/lib/kernel/Generator.ml b/lib/kernel/Generator.ml index 10f6865..204699f 100644 --- a/lib/kernel/Generator.ml +++ b/lib/kernel/Generator.ml @@ -10,7 +10,7 @@ let start produce = let resume k = Effect.Deep.continue k () -class producer_cursor produce on_release = +class producer_cursor produce finally = object (self) inherit Lifecycle.null inherit Identity.of_id @@ -19,13 +19,18 @@ class producer_cursor produce on_release = val mutable state : [`Fresh | `Live of (unit, step) Effect.Deep.continuation | `Done] = `Fresh method protocols : Protocols.Handle.protocol list = Protocols.[Cursor.make self] + + method private finish = + state <- `Done; + Option.iter (fun f -> f ()) finally + method private step : (Concepts.Tuple.t option, Concepts.Condition.condition) result = let settle = function | Element (tuple, k) -> state <- `Live k; Ok (Some tuple) | Finished r -> - state <- `Done; + self#finish; Result.map (fun () -> None) r in match state with @@ -47,12 +52,8 @@ class producer_cursor produce on_release = Ok Protocols.Cursor.{tuples= BatFingerTree.empty; exhausted= (state = `Done)} else fill 0 BatFingerTree.empty - method! release = - (match state with - | `Live _ -> Option.iter (fun f -> f ()) on_release - | `Fresh | `Done -> ()); - state <- `Done + method! release = match state with `Fresh | `Live _ -> self#finish | `Done -> () end -let cursor_of ?on_release produce = - new producer_cursor produce on_release |> Protocols.Handle.make +let cursor_of ?finally produce = + new producer_cursor produce finally |> Protocols.Handle.make diff --git a/lib/kernel/Lifecycle.ml b/lib/kernel/Lifecycle.ml index ff67ecf..772cb6e 100644 --- a/lib/kernel/Lifecycle.ml +++ b/lib/kernel/Lifecycle.ml @@ -23,7 +23,18 @@ class virtual counted = object (self) true method release = - Atomic.decr references; - if Atomic.get references <= 0 then + if Atomic.fetch_and_add references (-1) = 1 then self#destroy end + +class retaining inner (owner : lifecycle) = object + inherit counted + initializer ignore owner#reference + + method destroy = + Protocols.Handle.release inner; + owner#release + + method hash = Protocols.Handle.hash inner + method protocols = Protocols.Handle.protocols inner +end diff --git a/lib/kernel/Lifecycle.mli b/lib/kernel/Lifecycle.mli index f110768..fa3abee 100644 --- a/lib/kernel/Lifecycle.mli +++ b/lib/kernel/Lifecycle.mli @@ -10,3 +10,13 @@ end class null : lifecycle class virtual counted : controlled_lifecycle + +(** stands for [inner], carrying what it carries, while holding a + reference to [owner], so what [inner] reads outlives a release of + the object that produced it. *) +class retaining : Protocols.Handle.t -> lifecycle -> object + inherit lifecycle + method destroy : unit + method hash : Concepts.Hash.hash + method protocols : Protocols.Handle.protocol list +end diff --git a/lib/kernel/Storage.ml b/lib/kernel/Storage.ml index 665b1a7..d50735c 100644 --- a/lib/kernel/Storage.ml +++ b/lib/kernel/Storage.ml @@ -36,11 +36,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct let _ = S.abort tx in Error condition - let with_transaction connection body = + let within start connection body = let open Utilities.Result in - let* tx = S.start connection in + let* tx = start connection in body tx |> finish tx + let with_transaction connection = within S.start connection + let with_read connection = within S.start_read connection + let store_blob tx blob = let open Utilities.Result in let address = Concepts.Hash.hash_of_blob blob in diff --git a/lib/kernel/Storage.mli b/lib/kernel/Storage.mli index 3c036ca..53bb666 100644 --- a/lib/kernel/Storage.mli +++ b/lib/kernel/Storage.mli @@ -12,6 +12,7 @@ module Make : functor (S : Abstract.Storage.STORAGE) -> sig val finish : S.transaction -> ('a, Concepts.Condition.condition) result -> ('a, Concepts.Condition.condition) result val with_transaction : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result + val with_read : S.connection -> (S.transaction -> ('a, Concepts.Condition.condition) result) -> ('a, Concepts.Condition.condition) result val store_blob : S.transaction -> Concepts.Blob.t -> (Concepts.Hash.hash, Concepts.Condition.condition) result val get_req: S.transaction -> S.address -> (Concepts.Blob.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml index 136c146..52ce83c 100644 --- a/lib/kernel/SubstantialRelation.ml +++ b/lib/kernel/SubstantialRelation.ml @@ -120,30 +120,34 @@ module Make (S : Abstract.Storage.STORAGE) = struct kvs |> List.map (fun (name, domain) -> Concepts.Encoding.Bencode.as_string domain - |> Result.map (fun domain -> (name, domain))) + |> Result.map (fun domain -> + (name, {Protocols.Schematics.domain; provenance= []}) ) ) |> Utilities.List.sequence - |> Result.map (fun kvs -> - List.fold_left - (fun acc (name, domain) -> BatMap.String.add name domain acc) - BatMap.String.empty kvs) + |> Result.map BatMap.String.of_list - let enumerate storage relation = + let generate storage relation binding = let open Utilities.Result in - let* tx = S.start storage in - let* node = tuple_node tx relation in - let closed = ref false in - let close () = if not !closed then begin closed := true; ignore (S.abort tx) end in + let* tx = S.start_read storage in + let close () = ignore (S.abort tx) in + let* node = tuple_node tx relation |> Result.map_error (fun c -> close (); c) in (* The fold is suspended by [yield], so the tree is walked one node and one tuple at a time rather than materialized before the first tuple is produced. *) let produce ~yield = - let walked = TupleSet.iter tx (fun _ tuple -> yield tuple) node in - close (); - walked + TupleSet.iter tx + (fun _ tuple -> if Protocols.Generative.satisfies binding tuple then yield tuple) + node in - Ok (Generator.cursor_of ~on_release:close produce) + Ok (Generator.cursor_of ~finally:close produce) + + let enumerate storage relation = generate storage relation Protocols.Generative.nothing + + let modes_of description = + Concepts.Mode.of_list + [ Concepts.Mode.enumerable Concepts.Cardinality.Finite; + {Concepts.Mode.bound= Concepts.Mode.attributes_of_map description; affords= Decides} ] - class relation storage value = + class relation storage value description = object (self) inherit Lifecycle.null @@ -151,18 +155,16 @@ module Make (S : Abstract.Storage.STORAGE) = struct val storage : S.connection = storage val relation : t = value + val declaration = modes_of description method predicate = Ok relation.predicate method local_constraints = Ok relation.local_constraints (* The protocol takes a tuple, not bytes: encoding is this object's business, and a caller that had to produce the exact stored bytes would have to know this encoding to do it. *) method contains (tuple : Concepts.Tuple.t) = - SI.with_transaction storage (fun tx -> contains_tuple tx relation tuple) + SI.with_read storage (fun tx -> contains_tuple tx relation tuple) - method describe () = - let open Utilities.Result in - let* description = SI.with_transaction storage (fun tx -> schema_of tx relation) in - Ok (Protocols.Schematics.Relation description) + method describe () = Ok (Protocols.Schematics.Relation description) (* A substantial relation is finitely enumerable, so it carries [Enumerable] as well as [Relation]. A procedural relation would carry only the latter, which is how an evaluator @@ -171,30 +173,39 @@ module Make (S : Abstract.Storage.STORAGE) = struct no name resolution, but cancellation should eventually be checked between tuples. *) method enumerate = enumerate storage relation + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = Ok declaration + method generate binding = generate storage relation binding + method protocols : Protocols.Handle.protocol list = [ Protocols.Relation.make self ; Protocols.Enumerable.make self + ; Protocols.Generative.make self ; Protocols.Schematics.make self ] method hash = hash relation end + (* A relation never changes its schema, so it is read once here and + the description and modes are served from it on every request. *) + let instantiate tx conn relation = + schema_of tx relation + |> Result.map (fun description -> new relation conn relation description |> Protocols.Handle.make) + let make conn ~schematics ?predicate ?local_constraints ?indexes () = let open Utilities.Result in SI.with_transaction conn (fun tx -> let* relation = empty tx ~schematics ?predicate ?local_constraints ?indexes () in let* _ = store tx relation in - Ok (new relation conn relation |> Protocols.Handle.make) ) + instantiate tx conn relation ) let load_value tx addr = let open Utilities.Result in let* data = SI.get_req tx (S.Hash addr) in Representation.of_blob data - let wrap conn relation = - new relation conn relation |> Protocols.Handle.make |> Result.ok + let wrap conn relation = SI.with_read conn (fun tx -> instantiate tx conn relation) let load tx conn addr = - load_value tx addr |> Utilities.Result.fmap (wrap conn) + load_value tx addr |> Utilities.Result.fmap (instantiate tx conn) let assert_tuple tx relation tuple = let open Utilities.Result in diff --git a/lib/kernel/SubstantialRelation.mli b/lib/kernel/SubstantialRelation.mli index 5061e5d..a36c802 100644 --- a/lib/kernel/SubstantialRelation.mli +++ b/lib/kernel/SubstantialRelation.mli @@ -47,18 +47,10 @@ module Make (S : Abstract.Storage.STORAGE) : sig val contains_tuple : S.transaction -> t -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result - (** decodes the schematics at [schematics relation] -- the body of - [Protocols.Schematics.describe] for this kind of relation. *) val schema_of : S.transaction -> t -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result - (** a handle carrying [Protocols.Cursor] over every tuple currently - asserted, decoded via [Concepts.Tuple.Representation.of_blob] -- - the body of [Protocols.Relation.enumerate] for this kind of - relation. Opens its own storage transaction, held for the - cursor's whole lifetime rather than just this call -- see - [Kernel.Generator] and docs/design/evaluator.md, "Shape". *) val enumerate : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/protocols/Cursor.ml b/lib/protocols/Cursor.ml index 36db97d..75dc77d 100644 --- a/lib/protocols/Cursor.ml +++ b/lib/protocols/Cursor.ml @@ -26,6 +26,13 @@ let rec next i = | Some (_, tuple) -> Ok (Some tuple) | None -> if batch.exhausted then Ok None else next i +let rec exists i p = + let open Utilities.Result in + let* found = next i in + match found with + | None -> Ok false + | Some tuple -> if p tuple then Ok true else exists i p + let drain i ?(limit = 256) () = let open Utilities.Result in let rec loop tuples = diff --git a/lib/protocols/Cursor.mli b/lib/protocols/Cursor.mli index 08c7628..c977fec 100644 --- a/lib/protocols/Cursor.mli +++ b/lib/protocols/Cursor.mli @@ -14,6 +14,11 @@ val fetch : t Handle.interface -> int -> (batch, Concepts.Condition.condition) r val next : t Handle.interface -> (Concepts.Tuple.t option, Concepts.Condition.condition) result +val exists : + t Handle.interface -> + (Concepts.Tuple.t -> bool) -> + (bool, Concepts.Condition.condition) result + val drain : t Handle.interface -> ?limit:int -> diff --git a/lib/protocols/Generative.ml b/lib/protocols/Generative.ml new file mode 100644 index 0000000..bd89e21 --- /dev/null +++ b/lib/protocols/Generative.ml @@ -0,0 +1,81 @@ +module Error = struct + open Concepts.Condition + + let not_generative () = + condition "not-generative" + "A relation was used where the expression must produce members under a binding, but it \ + declares no modes. A relation that cannot be asked this way can still be reached through \ + another access path." + empty + + let attributes bound = Concepts.Value.String (String.concat ", " (BatSet.String.elements bound)) + + let ungenerable bound = + condition "ungenerable-binding" + "The relation declares no mode that generates under the attributes bound." + ("bound" |=| attributes bound) + + let undecidable bound = + condition "undecidable-membership" + "The relation declares no mode that decides membership under the attributes of the tuple." + ("bound" |=| attributes bound) +end + +type binding = Concepts.Value.value BatMap.String.t + +class type implementation = object + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result + method generate : binding -> (Handle.t, Concepts.Condition.condition) result +end + +type Handle.protocol += Generative of implementation +type t = implementation + +let make impl = Generative (impl :> implementation) +let from handle = Handle.into handle (function Generative impl -> Some impl | _ -> None) +let require handle = from handle |> Option.to_result ~none:(Error.not_generative ()) +let nothing = BatMap.String.empty +let bound = Concepts.Mode.attributes_of_map +let modes i = Handle.invoke i (fun o -> o#modes) + +let generate i binding = + Handle.invoke i (fun o -> + let open Utilities.Result in + let bound = bound binding in + let* declaration = o#modes in + if Option.is_some (Concepts.Mode.generation declaration bound) then o#generate binding + else Error (Error.ungenerable bound) ) + +let satisfies binding tuple = + BatMap.String.for_all + (fun attribute value -> + match BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes with + | Some found -> Concepts.Value.equal found value + | None -> false ) + binding + +class virtual membership = + object (self) + val virtual heading : Concepts.Mode.attributes + method virtual modes : (Concepts.Mode.t, Concepts.Condition.condition) result + method virtual generate : binding -> (Handle.t, Concepts.Condition.condition) result + + method contains (tuple : Concepts.Tuple.t) = + let open Utilities.Result in + let binding = tuple.Concepts.Tuple.attributes in + let bound = bound binding in + if not (BatSet.String.equal heading bound) then Ok false + else + let* declaration = self#modes in + let* () = + if Concepts.Mode.decision declaration bound then Ok () else Error (Error.undecidable bound) + in + let* cursor = self#generate binding in + let expected = Concepts.Tuple.hash tuple in + Fun.protect + ~finally:(fun () -> Handle.release cursor) + (fun () -> + let* scan = Cursor.require cursor in + Cursor.exists scan (fun member -> + Concepts.Hash.hash_equals (Concepts.Tuple.hash member) expected ) ) + end diff --git a/lib/protocols/Generative.mli b/lib/protocols/Generative.mli new file mode 100644 index 0000000..5ada329 --- /dev/null +++ b/lib/protocols/Generative.mli @@ -0,0 +1,35 @@ +type t + +(** values fixed for some of a relation's attributes, the attributes + absent from it being the ones left free. *) +type binding = Concepts.Value.value BatMap.String.t + +class type implementation = object + method modes : (Concepts.Mode.t, Concepts.Condition.condition) result + method generate : binding -> (Handle.t, Concepts.Condition.condition) result +end + +val make : #implementation -> Handle.protocol +val from : Handle.t -> t Handle.interface option +val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result +val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition) result + +(** a handle carrying a cursor over the members agreeing with the + binding and under the empty binding this is enumeration, so a + relation carrying enumerable answers the same members here. Refused + when no declared mode generates under the attributes bound. *) +val generate : t Handle.interface -> binding -> (Handle.t, Concepts.Condition.condition) result + +val nothing : binding +val bound : binding -> Concepts.Mode.attributes +val satisfies : binding -> Concepts.Tuple.t -> bool + +(** membership for a relation with no lookup of its own, asked of the + generator under the binding the tuple fixes. Only a tuple carrying + exactly the [heading] can be a member, and it must match one whole. *) +class virtual membership : object + val virtual heading : Concepts.Mode.attributes + method virtual modes : (Concepts.Mode.t, Concepts.Condition.condition) result + method virtual generate : binding -> (Handle.t, Concepts.Condition.condition) result + method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result +end diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index c45afb0..41c88dd 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -51,6 +51,7 @@ let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash let hash h = (object_of h)#hash +let protocols h = (object_of h)#protocols let to_string h = (object_of h)#to_string diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index daee453..40a78ff 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -24,6 +24,7 @@ val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash +val protocols : t -> protocol list val to_string : t -> string val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result diff --git a/lib/protocols/Schematics.ml b/lib/protocols/Schematics.ml index d2e50ad..49d8586 100644 --- a/lib/protocols/Schematics.ml +++ b/lib/protocols/Schematics.ml @@ -1,5 +1,7 @@ type multigroup_description = string BatMap.String.t -type relation_description = string BatMap.String.t +type origin = {source: string list; attribute: string} +type attribute_description = {domain: string; provenance: origin list} +type relation_description = attribute_description BatMap.String.t type tuple_description = {relation: relation_description; attributes: string BatMap.String.t} (* TODO: For now the description is completely detached from actual diff --git a/lib/protocols/Schematics.mli b/lib/protocols/Schematics.mli index dc8f320..fe81943 100644 --- a/lib/protocols/Schematics.mli +++ b/lib/protocols/Schematics.mli @@ -4,7 +4,17 @@ type t types and domains. Later figure out a way to represent the links without strings. *) type multigroup_description = string BatMap.String.t -type relation_description = string BatMap.String.t + +(** where an attribute comes from with the path relation and the + attribute it has. *) +type origin = {source: string list; attribute: string} + +(** an attribute of a derived relation may be for several occurrences + at once, for example in a natural join. So its provenance is a + collection. *) +type attribute_description = {domain: string; provenance: origin list} + +type relation_description = attribute_description BatMap.String.t type tuple_description = {relation: relation_description; attributes: string BatMap.String.t} type description = diff --git a/test/Helpers.ml b/test/Helpers.ml index 784170c..e859932 100644 --- a/test/Helpers.ml +++ b/test/Helpers.ml @@ -8,7 +8,7 @@ let rec recursively_remove path = else Sys.remove path let with_temporary_directory prefix ?(suffix = "") f = - let path = Filename.temp_dir ~temp_dir:"/tmp" prefix suffix in + let path = Filename.temp_dir ~temp_dir:(Filename.get_temp_dir_name ()) prefix suffix in Fun.protect (fun () -> f path) ~finally:(fun () -> recursively_remove path) let condition_as_failure = function @@ -31,12 +31,18 @@ module Storage = struct end module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct + module SI = Kernel.Storage.Make (S) + + let store_schema tx attributes = + Concepts.Encoding.Bencode.(Dict (List.map (fun a -> (a, String "string")) attributes) |> to_blob) + |> SI.store_blob tx + let with_connection f dir () = with_temporary_directory dir begin fun dir -> begin let open Utilities.Result in let* conn = S.connect (C.configure dir) in - Ok (f conn) + Ok (Fun.protect ~finally:(fun () -> S.disconnect conn) (fun () -> f conn)) end |> condition_as_failure end diff --git a/test/test_rnt.ml b/test/test_rnt.ml index d9936ea..b9c5962 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -1,5 +1,7 @@ let all_suites = Unit.Backend.Storage.suites () + @ Unit.Concepts.Cardinality.suites () + @ Unit.Kernel.EphemeralRelation.suites () @ Unit.Kernel.Merkle.suites () @ Unit.Kernel.SubstantialRelation.suites () @ Unit.Evaluators.FOL.suites () diff --git a/test/unit/concepts/Cardinality.ml b/test/unit/concepts/Cardinality.ml new file mode 100644 index 0000000..a60c472 --- /dev/null +++ b/test/unit/concepts/Cardinality.ml @@ -0,0 +1,24 @@ +open Alcotest + +module C = Rnt.Concepts.Cardinality + +let klass = testable (fun ppf c -> Format.pp_print_string ppf (C.to_string c)) C.equal + +let chain () = + check bool "empty is least" true (C.leq C.Empty C.Countable); + check bool "a tighter ceiling is smaller" true (C.leq (C.Bounded 2) (C.Bounded 5)); + check bool "a ceiling is finite" true (C.leq (C.Bounded 5) C.Finite); + check bool "countable is greatest" true (C.leq C.Finite C.Countable); + check bool "and nothing above it" false (C.leq C.Countable C.Finite) + +let exhaustion () = + check bool "a bounded generator can be exhausted" true (C.exhaustible (C.Bounded 3)); + check bool "a countable one cannot" false (C.exhaustible C.Countable) + +let emptiness () = check klass "a ceiling of zero is emptiness" C.Empty (C.bounded 0) + +let suites () = + [ ( "concepts/cardinality", + [ test_case "chain" `Quick chain; + test_case "exhaustion" `Quick exhaustion; + test_case "emptiness" `Quick emptiness ] ) ] diff --git a/test/unit/evaluators/FOL.ml b/test/unit/evaluators/FOL.ml index cf8aedb..9cfeb84 100644 --- a/test/unit/evaluators/FOL.ml +++ b/test/unit/evaluators/FOL.ml @@ -6,9 +6,6 @@ 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 hash s = - Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob - let alaric = { Concepts.Tuple.type_ = "employee"; attributes = @@ -28,7 +25,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = begin let open Utilities.Result in let* tx = S.start conn in - let* relation = SR.empty tx ~schematics:(hash "schema") () in + let* schematics = H.store_schema tx ["name"] in + let* relation = SR.empty tx ~schematics () in let* relation = SR.assert_tuple tx relation alaric in let* () = S.commit tx in let* employee = SR.wrap conn relation in diff --git a/test/unit/evaluators/Lambda.ml b/test/unit/evaluators/Lambda.ml index b30fe33..5866411 100644 --- a/test/unit/evaluators/Lambda.ml +++ b/test/unit/evaluators/Lambda.ml @@ -6,9 +6,6 @@ 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 hash s = - Concepts.Blob.blob_of_bytes (Bytes.of_string s) |> Concepts.Hash.hash_of_blob - let datum = { Concepts.Tuple.type_ = "noun"; attributes = @@ -36,8 +33,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let evaluate conn term = let open Utilities.Result in let* tx = S.start conn in + let* schematics = H.store_schema tx ["lemma"] in let singleton tuple = - let* relation = SR.empty tx ~schematics:(hash "schema") () in + let* relation = SR.empty tx ~schematics () in SR.assert_tuple tx relation tuple in let* noun = singleton datum in diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml new file mode 100644 index 0000000..a72409b --- /dev/null +++ b/test/unit/kernel/EphemeralRelation.ml @@ -0,0 +1,151 @@ +open Alcotest + +module Concepts = Rnt.Concepts +module Protocols = Rnt.Protocols + +(* A derivation over a fixed set of members. It reads nothing and + computes nothing, so what the tests observe is the kernel object + rather than any particular evaluator. *) +module Derivation = struct + type plan = {name: string; members: Concepts.Tuple.t list; declared: Concepts.Mode.t} + + let identity {name; _} = Concepts.Hash.hash_of_bytes (Bytes.of_string name) + + let describe _ = + Ok + (BatMap.String.singleton "value" + { Protocols.Schematics.domain = "integer"; + provenance = [{Protocols.Schematics.source = ["example"]; attribute = "value"}] } ) + + let modes {declared; _} = Ok declared + + let generate {members; _} binding = + Ok + (Rnt.Kernel.Generator.cursor_of (fun ~yield -> + List.iter + (fun member -> if Protocols.Generative.satisfies binding member then yield member) + members; + Ok () ) ) +end + +module Derived = Rnt.Kernel.EphemeralRelation.Make (Derivation) + +let member n = + { Concepts.Tuple.type_ = "example"; + attributes = BatMap.String.singleton "value" (Concepts.Value.Integer n) } + +let plan_over cardinality = + { Derivation.name = "the-derivation"; + members = [member 1; member 2; member 3]; + declared = + Concepts.Mode.of_list + [Concepts.Mode.enumerable cardinality; Concepts.Mode.decides_when ["value"]] } + +let derive plan = Derived.derive plan |> Helpers.condition_as_failure + +let values tuples = + BatFingerTree.to_list tuples + |> List.filter_map (fun tuple -> + match BatMap.String.find_opt "value" tuple.Concepts.Tuple.attributes with + | Some (Concepts.Value.Integer n) -> Some n + | _ -> None ) + |> List.sort compare + +let commit = Concepts.Hash.hash_of_bytes (Bytes.of_string "a-commit") + +let identity_is_the_derivation () = + let plan = plan_over Concepts.Cardinality.Finite in + check bool "unpinned, the identity of the plan" true + (Concepts.Hash.hash_equals (Derived.identity plan) (Derivation.identity plan)); + check bool "pinned to a commit, another identity" false + (Concepts.Hash.hash_equals (Derived.identity plan) (Derived.identity ~pinned:commit plan)); + check bool "the same pin twice is the same identity" true + (Concepts.Hash.hash_equals + (Derived.identity ~pinned:commit plan) + (Derived.identity ~pinned:commit plan) ) + +let an_exhaustible_derivation_enumerates () = + let derived = derive (plan_over Concepts.Cardinality.Finite) in + let enumerated = + begin + let open Rnt.Utilities.Result in + let* enumerable = Protocols.Enumerable.require derived in + let* cursor = Protocols.Enumerable.enumerate enumerable in + let* scan = Protocols.Cursor.require cursor in + let* tuples = Protocols.Cursor.drain scan () in + Protocols.Handle.release cursor; + Ok (values tuples) + end + |> Helpers.condition_as_failure + in + check (list int) "every member" [1; 2; 3] enumerated + +let a_countable_derivation_decides_only () = + let derived = derive (plan_over Concepts.Cardinality.Countable) in + let holds, rejects = + begin + let open Rnt.Utilities.Result in + let* relation = Protocols.Relation.require derived in + let* holds = Protocols.Relation.contains relation (member 2) in + let* rejects = Protocols.Relation.contains relation (member 9) in + Ok (holds, rejects) + end + |> Helpers.condition_as_failure + in + check bool "no enumeration is offered" false + (Option.is_some (Protocols.Enumerable.from derived)); + check bool "membership is still decided" true holds; + check bool "and still refused" false rejects + +let a_derivation_describes_itself () = + let derived = derive (plan_over Concepts.Cardinality.Finite) in + let described = + begin + let open Rnt.Utilities.Result in + let* schematics = Protocols.Handle.require Protocols.Schematics.from derived in + Protocols.Schematics.describe schematics + end + |> Helpers.condition_as_failure + in + match described with + | Protocols.Schematics.Relation description -> + check (list string) "the attributes of the result" ["value"] + (BatMap.String.keys description |> BatList.of_enum); + check (list string) "and where each was drawn from" ["example/value"] + ( BatMap.String.values description + |> BatList.of_enum + |> List.concat_map (fun attribute -> + attribute.Protocols.Schematics.provenance + |> List.map (fun origin -> + String.concat "/" origin.Protocols.Schematics.source + ^ "/" ^ origin.Protocols.Schematics.attribute ) ) ) + | _ -> fail "a derived relation describes itself as a relation" + +let releasing_a_derivation_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 + method protocols : Protocols.Handle.protocol list = [] + end + in + let edge = Protocols.Handle.make input in + let derived = + Derived.derive ~edges:[edge] (plan_over Concepts.Cardinality.Finite) + |> Helpers.condition_as_failure + in + check bool "an input is held while the derivation lives" false !released; + Protocols.Handle.release derived; + check bool "and released with it" true !released + +let suites () = + [ ( "kernel/ephemeral-relation", + [ test_case "identity-is-the-derivation" `Quick identity_is_the_derivation; + test_case "an-exhaustible-derivation-enumerates" `Quick + an_exhaustible_derivation_enumerates; + test_case "a-countable-derivation-decides-only" `Quick a_countable_derivation_decides_only; + test_case "a-derivation-describes-itself" `Quick a_derivation_describes_itself; + test_case "releasing-a-derivation-releases-its-inputs" `Quick + releasing_a_derivation_releases_its_inputs ] ) ] |