diff options
Diffstat (limited to 'lib/concepts/Heading.ml')
| -rw-r--r-- | lib/concepts/Heading.ml | 100 |
1 files changed, 0 insertions, 100 deletions
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 |