heading concept for tuple handling

2 files changed, 124 insertions, 0 deletions

diff --git a/lib/concepts/Heading.ml b/lib/concepts/Heading.ml
new file mode 100644
index 0000000..58bbef9
--- /dev/null
+++ b/lib/concepts/Heading.ml
@@ -0,0 +1,100 @@
+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
new file mode 100644
index 0000000..98b8e60
--- /dev/null
+++ b/lib/concepts/Heading.mli
@@ -0,0 +1,24 @@
+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