1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
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
|
