blob: 4947869c06a4f0ce233c46eb42ff07b866d7ec69 (
plain) (
blame)
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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
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
module Error = struct
open Concepts.Condition
let attributes bound = Concepts.Value.String (String.concat ", " (BatSet.String.elements bound))
let ungenerable bound =
condition "ungenerable-binding"
"The derivation declares no mode that generates under the attributes bound."
("bound" |=| attributes bound)
let undecidable bound =
condition "undecidable-membership"
"The derivation declares no mode that decides membership under the attributes of the tuple."
("bound" |=| attributes bound)
end
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
let exhaustible declaration bound =
match Concepts.Mode.generation declaration bound with
| Some cardinality -> Concepts.Cardinality.exhaustible cardinality
| None -> false
let decides declaration bound =
Concepts.Mode.decision declaration bound || exhaustible declaration bound
(* A cursor holds a reference to its relation, so the edges it reads
outlive a release of the relation that produced it. *)
class retaining scan release_owner =
object (self)
inherit Lifecycle.counted
inherit Identity.of_id
method destroy =
Protocols.Handle.release (Protocols.Handle.from scan);
release_owner ()
method fetch limit = Protocols.Cursor.fetch scan limit
method protocols : Protocols.Handle.protocol list = [Protocols.Cursor.make self]
end
class ephemeral plan address declaration total edges =
object (self)
inherit Lifecycle.counted
val plan : D.plan = plan
method destroy = List.iter Protocols.Handle.release edges
method predicate = Ok None
method local_constraints = Ok None
method modes = Ok declaration
method private retained binding =
let open Utilities.Result in
let bound = Protocols.Generative.bound binding in
let* () =
if Option.is_some (Concepts.Mode.generation declaration bound) then Ok ()
else Error (Error.ungenerable bound)
in
let* cursor = D.generate plan binding in
match Protocols.Cursor.require cursor with
| Error c ->
Protocols.Handle.release cursor;
Error c
| Ok scan ->
ignore self#reference;
Ok (new retaining scan (fun () -> self#release) |> Protocols.Handle.make)
method generate binding = self#retained binding
method enumerate = self#retained Protocols.Generative.nothing
method describe () =
D.describe plan |> Result.map (fun description -> Protocols.Schematics.Relation description)
(* Membership of a derived relation is decided by the derivation
and not by a lookup, so it is asked of the generator under the
binding the tuple itself fixes. Only a tuple carrying exactly the
described attributes can be a member, and it must match one whole. *)
method contains (tuple : Concepts.Tuple.t) =
let open Utilities.Result in
let binding = tuple.Concepts.Tuple.attributes in
let bound = Protocols.Generative.bound binding in
let* description = D.describe plan in
let described = BatMap.String.keys description |> BatSet.String.of_enum in
if not (BatSet.String.equal described bound) then Ok false
else
let* () = if decides declaration bound then Ok () else Error (Error.undecidable bound) in
let* cursor = D.generate plan binding in
let expected = Concepts.Tuple.hash tuple in
Fun.protect
~finally:(fun () -> Protocols.Handle.release cursor)
(fun () ->
let* scan = Protocols.Cursor.require cursor in
let rec seek () =
let* found = Protocols.Cursor.next scan in
match found with
| None -> Ok false
| Some member ->
if Concepts.Hash.hash_equals (Concepts.Tuple.hash member) expected then Ok true
else seek ()
in
seek () )
method protocols : Protocols.Handle.protocol list =
let carried =
[ Protocols.Relation.make self;
Protocols.Schematics.make self;
Protocols.Generative.make self ]
in
if total 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* declaration =
D.modes plan |> Result.map_error (fun c -> List.iter Protocols.Handle.release edges; c)
in
Ok
( new ephemeral plan (identity ?pinned plan) declaration (exhaustible declaration BatSet.String.empty) edges
|> Protocols.Handle.make )
end
|
