blob: 29b15ed598f65c2afcde939e7fc8aff51ff432c1 (
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
|
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
(* 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 : D.plan) address declaration description edges =
object (self)
inherit Lifecycle.counted
val heading = BatMap.String.keys description |> BatSet.String.of_enum
method destroy = List.iter Protocols.Handle.release edges
method predicate = Ok None
method local_constraints = Ok None
method modes = Ok declaration
method generate 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 enumerate = self#generate Protocols.Generative.nothing
method describe () = Ok (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
if not (BatSet.String.equal heading bound) then Ok false
else
let* () =
if Concepts.Mode.decision 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 Concepts.Mode.exhaustible declaration BatSet.String.empty 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 derived =
let* declaration = D.modes plan in
let* description = D.describe plan in
Ok
( new ephemeral plan (identity ?pinned plan) declaration description edges
|> Protocols.Handle.make )
in
Result.iter_error (fun _ -> List.iter Protocols.Handle.release edges) derived;
derived
end
|
