aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/abstract/Schematics.ml8
-rw-r--r--lib/concepts/Heading.ml100
-rw-r--r--lib/concepts/Heading.mli24
-rw-r--r--lib/concepts/Tuple.ml89
-rw-r--r--lib/concepts/Tuple.mli19
-rw-r--r--lib/kernel/Tuple.ml137
-rw-r--r--lib/protocols/Evaluator.ml12
-rw-r--r--lib/protocols/Evaluator.mli11
-rw-r--r--lib/protocols/Schematics.ml42
-rw-r--r--lib/protocols/Schematics.mli31
10 files changed, 172 insertions, 301 deletions
diff --git a/lib/abstract/Schematics.ml b/lib/abstract/Schematics.ml
deleted file mode 100644
index 9a98a13..0000000
--- a/lib/abstract/Schematics.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-module type SCHEMA = sig
- type t
- type attribute
- val attributes : t -> (string * attribute) BatFingerTree.t
- val project : t -> string BatFingerTree.t -> (t, Concepts.Condition.condition) result
- val rename : t -> (string * string) BatFingerTree.t -> (t, Concepts.Condition.condition) result
- val merge : t -> t -> (t, Concepts.Condition.condition) result
-end
diff --git a/lib/concepts/Heading.ml b/lib/concepts/Heading.ml
deleted file mode 100644
index 58bbef9..0000000
--- a/lib/concepts/Heading.ml
+++ /dev/null
@@ -1,100 +0,0 @@
-type t = (string, string) BatMap.t
-
-let of_alist pairs = List.fold_left (fun acc (name, domain) -> BatMap.add name domain acc) BatMap.empty pairs
-
-(* Relies on BatMap's iteration order being key order (it is, for the
- polymorphic tree map keyed by Stdlib.compare on strings), rather
- than sorting again on every call. *)
-let attributes heading =
- BatMap.foldi (fun name domain acc -> BatFingerTree.snoc acc (name, domain)) heading BatFingerTree.empty
-
-let names heading = BatMap.foldi (fun name _ acc -> BatSet.add name acc) heading BatSet.empty
-let arity heading = BatMap.cardinal heading
-let mem name heading = BatMap.mem name heading
-
-module Error = struct
- open Condition
-
- let unknown_attribute name =
- condition "unknown-attribute" "No such attribute on this heading"
- ("attribute" |=| Value.String name)
-
- let incompatible_domain name =
- condition "incompatible-domain" "The same attribute name is declared on two different domains"
- ("attribute" |=| Value.String name)
-end
-
-let domain_of name heading =
- match BatMap.find_opt name heading with
- | Some domain -> Ok domain
- | None -> Error (Error.unknown_attribute name)
-
-let project names heading =
- let open Utilities.Result in
- BatFingerTree.fold_left
- (fun acc name ->
- let* acc = acc in
- let* domain = domain_of name heading in
- if BatMap.mem name acc then
- Error (Condition.condition "duplicate-attribute" "An attribute was selected more than once"
- Condition.("attribute" |=| Value.String name))
- else Ok (BatMap.add name domain acc))
- (Ok BatMap.empty) names
-
-let rename pairs heading =
- let open Utilities.Result in
- BatFingerTree.fold_left
- (fun acc (old_name, new_name) ->
- let* acc = acc in
- let* domain = domain_of old_name heading in
- if BatMap.mem new_name acc then
- Error (Condition.condition "duplicate-attribute" "Two attributes have the same renamed name"
- Condition.("attribute" |=| Value.String new_name))
- else Ok (BatMap.add new_name domain acc))
- (Ok BatMap.empty) pairs
-
-let shared left right = BatSet.intersect (names left) (names right)
-
-(* TODO: this checks that shared attributes agree on domain, then
- takes their union favouring [right]'s bindings for the shared names
- (they already agree, so it doesn't matter which side wins). It does
- NOT guard against two attributes that happen to share a name and a
- domain tag by coincidence rather than by being "the same" join
- column. Domain tags are (for now at least) opaque unchecked
- strings. Refer to the docs/object-taxonomy.org Schematics section
- for more. *)
-let joined left right =
- let open Utilities.Result in
- BatSet.fold
- (fun name acc ->
- let* acc = acc in
- let* dl = domain_of name left in
- let* dr = domain_of name right in
- if dl = dr then Ok acc else Error (Error.incompatible_domain name))
- (shared left right) (Ok ())
- |> Result.map (fun () -> BatMap.foldi BatMap.add right left)
-
-let compatible left right = BatMap.equal ( = ) left right
-
-module rec Representation : (Encoding.Record.S with type t = t) = Encoding.Record.Make (Body)
-
-and Body : Encoding.Record.BODY = struct
- type nonrec t = t
-
- let tag = 'H'
-
- let malformed () =
- Condition.condition "malformed-heading"
- "The on-disk representation of a heading did not conform to what was expected" Condition.empty
-
- let fields heading =
- BatMap.foldi (fun name domain acc -> (name, Encoding.Bencode.String domain) :: acc) heading []
-
- let of_fields data =
- let open Utilities.Result in
- let* kvs = Encoding.Bencode.as_dict data in
- kvs
- |> List.map (fun (name, v) -> Encoding.Bencode.as_string v |> Result.map (fun d -> (name, d)))
- |> Utilities.List.sequence
- |> Result.map (List.fold_left (fun acc (name, d) -> BatMap.add name d acc) BatMap.empty)
-end
diff --git a/lib/concepts/Heading.mli b/lib/concepts/Heading.mli
deleted file mode 100644
index 98b8e60..0000000
--- a/lib/concepts/Heading.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-type t
-
-val of_alist : (string * string) list -> t
-
-(** attributes in name order. *)
-val attributes : t -> (string * string) BatFingerTree.t
-
-val names : t -> string BatSet.t
-val arity : t -> int
-val mem : string -> t -> bool
-
-module Error : sig
- val unknown_attribute : string -> Condition.condition
- val incompatible_domain : string -> Condition.condition
-end
-
-val domain_of : string -> t -> (string, Condition.condition) result
-val project : string BatFingerTree.t -> t -> (t, Condition.condition) result
-val rename : (string * string) BatFingerTree.t -> t -> (t, Condition.condition) result
-val shared : t -> t -> string BatSet.t
-val joined : t -> t -> (t, Condition.condition) result
-val compatible : t -> t -> bool
-
-module Representation : Encoding.Record.S with type t = t
diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml
deleted file mode 100644
index dc6eb5f..0000000
--- a/lib/concepts/Tuple.ml
+++ /dev/null
@@ -1,89 +0,0 @@
-type t = (string, Value.value) BatMap.t
-
-let empty = BatMap.empty
-let is_empty = BatMap.is_empty
-let set = BatMap.add
-let find_opt = BatMap.find_opt
-
-module Error = struct
- open Condition
-
- let unknown_attribute name =
- condition "unknown-attribute" "No such attribute on this tuple"
- ("attribute" |=| Value.String name)
-end
-
-let get name tuple =
- match BatMap.find_opt name tuple with
- | Some v -> Ok v
- | None -> Error (Error.unknown_attribute name)
-
-let attributes tuple = BatMap.foldi (fun name _ acc -> BatSet.add name acc) tuple BatSet.empty
-
-let project names tuple =
- let open Utilities.Result in
- BatFingerTree.fold_left
- (fun acc name ->
- let* acc = acc in
- let* value = get name tuple in
- Ok (set name value acc))
- (Ok empty) names
-
-let rename pairs tuple =
- let open Utilities.Result in
- BatFingerTree.fold_left
- (fun acc (old_name, new_name) ->
- let* acc = acc in
- let* value = get old_name tuple in
- Ok (set new_name value acc))
- (Ok empty) pairs
-
-let merge left right =
- BatMap.foldi
- (fun name value acc ->
- match acc with
- | None -> None
- | Some acc -> (
- match BatMap.find_opt name acc with
- | None -> Some (BatMap.add name value acc)
- | Some value' -> if Value.equal value value' then Some acc else None))
- right (Some left)
-
-(* Tuple's own wire format for a single value: kept local rather than
- added to Concepts.Encoding.Value (which only ever encodes hashes and
- options of them today) so this module owns its representation
- end to end. *)
-let bencode_of_value = function
- | Value.String s -> Encoding.Bencode.Tagged ('s', Encoding.Bencode.String s)
- | Value.Integer n -> Encoding.Bencode.Tagged ('i', Encoding.Bencode.Int n)
-
-let malformed_value () =
- Condition.condition "malformed-tuple-value"
- "A tuple field did not conform to what was expected" Condition.empty
-
-let value_of_bencode = function
- | Encoding.Bencode.Tagged ('s', Encoding.Bencode.String s) -> Ok (Value.String s)
- | Encoding.Bencode.Tagged ('i', Encoding.Bencode.Int n) -> Ok (Value.Integer n)
- | _ -> Error (malformed_value ())
-
-module rec Representation : (Encoding.Record.S with type t = t) = Encoding.Record.Make (Body)
-
-and Body : Encoding.Record.BODY = struct
- type nonrec t = t
-
- let tag = 'T'
- let malformed = malformed_value
-
- let fields tuple =
- BatMap.foldi (fun name value acc -> (name, bencode_of_value value) :: acc) tuple []
-
- let of_fields data =
- let open Utilities.Result in
- let* kvs = Encoding.Bencode.as_dict data in
- kvs
- |> List.map (fun (name, v) -> value_of_bencode v |> Result.map (fun v -> (name, v)))
- |> Utilities.List.sequence
- |> Result.map (List.fold_left (fun acc (name, v) -> set name v acc) empty)
-end
-
-let hash tuple = Representation.to_blob tuple |> Hash.hash_of_blob
diff --git a/lib/concepts/Tuple.mli b/lib/concepts/Tuple.mli
deleted file mode 100644
index 06542c8..0000000
--- a/lib/concepts/Tuple.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-type t
-
-val empty : t
-val is_empty : t -> bool
-val set : string -> Value.value -> t -> t
-val find_opt : string -> t -> Value.value option
-
-module Error : sig
- val unknown_attribute : string -> Condition.condition
-end
-
-val get : string -> t -> (Value.value, Condition.condition) result
-val attributes : t -> string BatSet.t
-val project : string BatFingerTree.t -> t -> (t, Condition.condition) result
-val rename : (string * string) BatFingerTree.t -> t -> (t, Condition.condition) result
-val merge : t -> t -> t option
-val hash : t -> Hash.hash
-
-module Representation : Encoding.Record.S with type t = t
diff --git a/lib/kernel/Tuple.ml b/lib/kernel/Tuple.ml
new file mode 100644
index 0000000..e8f2f7f
--- /dev/null
+++ b/lib/kernel/Tuple.ml
@@ -0,0 +1,137 @@
+module Make (S : Abstract.Storage.STORAGE) = struct
+ module SI = Storage.Make (S)
+
+ module Error = struct
+ open Concepts.Condition
+
+ let unknown_attribute name =
+ condition "unknown-attribute" "No such attribute on this tuple"
+ ("attribute" |=| Concepts.Value.String name)
+ let malformed_value () =
+ condition "malformed-tuple-value"
+ "A tuple field did not conform to what was expected" empty
+ let incomplete_tuple addr =
+ condition "incomplete-tuple"
+ "A stored tuple is missing part of its expected structure. Is your storage corrupted?"
+ ("address" |=| Concepts.Value.String (Concepts.Hash.to_hum_string addr))
+ end
+
+ module Attribute = struct
+ type t = Concepts.Value.value
+
+ let encode value =
+ let open Concepts.Encoding in
+ Bencode.to_blob
+ (match value with
+ | Concepts.Value.String s -> Bencode.Tagged ('s', Bencode.String s)
+ | Concepts.Value.Integer n -> Bencode.Tagged ('i', Bencode.Int n))
+
+ let decode blob =
+ let open Utilities.Result in
+ let open Concepts.Encoding in
+ let* data = Bencode.of_blob blob in
+ match data with
+ | Bencode.Tagged ('s', Bencode.String s) -> Ok (Concepts.Value.String s)
+ | Bencode.Tagged ('i', Bencode.Int n) -> Ok (Concepts.Value.Integer n)
+ | _ -> Error (Error.malformed_value ())
+
+ let domain = function
+ | Concepts.Value.String _ -> "string"
+ | Concepts.Value.Integer _ -> "integer"
+ end
+
+ module AttributeM = Merkle.Interface (S) (Merkle.StringKey) (Attribute)
+
+ type t = { type_ : string; attributes : AttributeM.address }
+
+ module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
+ Concepts.Encoding.Record.Make (Body)
+
+ and Body : Concepts.Encoding.Record.BODY = struct
+ type nonrec t = t
+
+ let tag = 'T'
+ let malformed = Error.malformed_value
+
+ let fields { type_; attributes } =
+ let open Concepts.Encoding in
+ [ "type", Bencode.String type_;
+ "attributes", Value.bencode_of_hash attributes ]
+
+ let of_fields data =
+ let open Utilities.Result in
+ let open Concepts.Encoding in
+ let* type_ = Bencode.field "type" data |> fmap Bencode.as_string in
+ let* attributes = Bencode.field "attributes" data |> fmap Value.hash_of_bencode in
+ Ok { type_; attributes }
+ end
+
+ let encode = Representation.to_blob
+ let decode = Representation.of_blob
+ let hash tuple = Representation.to_blob tuple |> Concepts.Hash.hash_of_blob
+
+ let type_of { type_; _ } = type_
+
+ let node tx { attributes; _ } =
+ let open Utilities.Result in
+ AttributeM.find tx attributes
+ |> fmap (Option.to_result ~none:(Error.incomplete_tuple attributes))
+
+ let empty tx ~type_ () =
+ let open Utilities.Result in
+ let* attributes = AttributeM.empty_under tx in
+ Ok { type_; attributes }
+
+ let make tx ~type_ attributes =
+ let open Utilities.Result in
+ let* node =
+ AttributeM.with_batch tx (fun () ->
+ BatMap.String.foldi
+ (fun name value node ->
+ let* node = node in
+ AttributeM.insert tx name value node)
+ attributes (Ok AttributeM.empty))
+ in
+ Ok { type_; attributes = AttributeM.hash_of node }
+
+ let attribute tx tuple name =
+ let open Utilities.Result in
+ let* node = node tx tuple in
+ let* value = AttributeM.lookup tx name node in
+ Option.to_result ~none:(Error.unknown_attribute name) value
+
+ let attributes tx tuple =
+ let open Utilities.Result in
+ let* node = node tx tuple in
+ AttributeM.fold_left tx
+ (fun acc name value -> BatMap.String.add name value acc)
+ BatMap.String.empty node
+
+ class tuple ~relation conn value node = object (self)
+ inherit Lifecycle.null
+
+ val tuple = value
+ val storage = conn
+ val node = node
+
+ method describe () =
+ let open Utilities.Result in
+ let* attributes =
+ SI.with_transaction storage (fun tx ->
+ AttributeM.fold_left tx
+ (fun acc name value -> BatMap.String.add name (Attribute.domain value) acc)
+ BatMap.String.empty node)
+ in
+ Ok (Protocols.Schematics.Tuple { Protocols.Schematics.relation; attributes })
+
+ method protocols : Protocols.Handle.protocol list =
+ [Protocols.Schematics.make self]
+
+ method hash = hash tuple
+ end
+
+ let wrap ~relation conn value =
+ let open Utilities.Result in
+ let* node = SI.with_transaction conn (fun tx -> node tx value) in
+ new tuple ~relation conn value node |> Protocols.Handle.make |> Result.ok
+end
diff --git a/lib/protocols/Evaluator.ml b/lib/protocols/Evaluator.ml
deleted file mode 100644
index 95c2ef8..0000000
--- a/lib/protocols/Evaluator.ml
+++ /dev/null
@@ -1,12 +0,0 @@
-class type implementation = object
- method capabilities : string BatSet.t
- method admit : string -> (Handle.t, Concepts.Condition.condition) result
-end
-
-type Handle.protocol += Evaluator of implementation
-type t = implementation
-
-let make impl = Evaluator (impl :> implementation)
-let from handle = Handle.into handle (function Evaluator impl -> Some impl | _ -> None)
-let capabilities i = Handle.invoke i (fun o -> o#capabilities)
-let admit i source = Handle.invoke i (fun o -> o#admit source)
diff --git a/lib/protocols/Evaluator.mli b/lib/protocols/Evaluator.mli
deleted file mode 100644
index 8400fd2..0000000
--- a/lib/protocols/Evaluator.mli
+++ /dev/null
@@ -1,11 +0,0 @@
-type t
-
-class type implementation = object
- method capabilities : string BatSet.t
- method admit : string -> (Handle.t, Concepts.Condition.condition) result
-end
-
-val make : #implementation -> Handle.protocol
-val from : Handle.t -> t Handle.interface option
-val capabilities : t Handle.interface -> string BatSet.t
-val admit : t Handle.interface -> string -> (Handle.t, Concepts.Condition.condition) result
diff --git a/lib/protocols/Schematics.ml b/lib/protocols/Schematics.ml
index b0297e7..d2e50ad 100644
--- a/lib/protocols/Schematics.ml
+++ b/lib/protocols/Schematics.ml
@@ -1,30 +1,24 @@
-module type S = sig
- module Schema : Abstract.Schematics.SCHEMA
- type t
+type multigroup_description = string BatMap.String.t
+type relation_description = string BatMap.String.t
+type tuple_description = {relation: relation_description; attributes: string BatMap.String.t}
- class type implementation = object
- method schema : (Schema.t, Concepts.Condition.condition) result
- end
+(* TODO: For now the description is completely detached from actual
+ types and domains. Later figure out a way to represent the links
+ without strings. *)
+type description =
+ | Multigroup of multigroup_description
+ | Relation of relation_description
+ | Tuple of tuple_description
- val make : #implementation -> Handle.protocol
- val from : Handle.t -> t Handle.interface option
- val schema : t Handle.interface -> (Schema.t, Concepts.Condition.condition) result
- val attributes :
- t Handle.interface ->
- ((string * Schema.attribute) BatFingerTree.t, Concepts.Condition.condition) result
+class type implementation = object
+ method describe : unit -> (description, Concepts.Condition.condition) result
end
-module Make (Schema : Abstract.Schematics.SCHEMA) = struct
- module Schema = Schema
- class type implementation = object
- method schema : (Schema.t, Concepts.Condition.condition) result
- end
+type Handle.protocol += Schematics of implementation
- type Handle.protocol += Schematics of implementation
- type t = implementation
+type t = implementation
- let make impl = Schematics (impl :> implementation)
- let from handle = Handle.into handle (function Schematics impl -> Some impl | _ -> None)
- let schema i = Handle.invoke i (fun o -> o#schema)
- let attributes i = Result.map Schema.attributes (schema i)
-end
+let make impl = Schematics (impl :> implementation)
+let from handle =
+ Handle.into handle (function Schematics impl -> Some impl | _ -> None)
+let describe impl = Handle.invoke impl (fun o -> o#describe ())
diff --git a/lib/protocols/Schematics.mli b/lib/protocols/Schematics.mli
index d8533bf..dc8f320 100644
--- a/lib/protocols/Schematics.mli
+++ b/lib/protocols/Schematics.mli
@@ -1,18 +1,21 @@
-(** Instantiate once and share the protocol with schema providers and evaluators. *)
-module type S = sig
- module Schema : Abstract.Schematics.SCHEMA
- type t
+type t
- class type implementation = object
- method schema : (Schema.t, Concepts.Condition.condition) result
- end
+(* TODO: For now the description is completely detached from actual
+ 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
+type tuple_description = {relation: relation_description; attributes: string BatMap.String.t}
- val make : #implementation -> Handle.protocol
- val from : Handle.t -> t Handle.interface option
- val schema : t Handle.interface -> (Schema.t, Concepts.Condition.condition) result
- val attributes :
- t Handle.interface ->
- ((string * Schema.attribute) BatFingerTree.t, Concepts.Condition.condition) result
+type description =
+ | Multigroup of multigroup_description
+ | Relation of relation_description
+ | Tuple of tuple_description
+
+class type implementation = object
+ method describe : unit -> (description, Concepts.Condition.condition) result
end
-module Make (Schema : Abstract.Schematics.SCHEMA) : S with module Schema = Schema
+val make : #implementation -> Handle.protocol
+val from : Handle.t -> t Handle.interface option
+val describe : t Handle.interface -> (description, Concepts.Condition.condition) result
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 07:27:42 +0000