blob: 3fb8e72c5040202322f774db5f1411b8e2eeb1a5 (
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
|
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. *)
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* () = if decides declaration bound then Ok () else Error (Error.undecidable bound) in
let* cursor = D.generate plan binding in
Fun.protect
~finally:(fun () -> Protocols.Handle.release cursor)
(fun () ->
let* scan = Protocols.Cursor.require cursor in
let* first = Protocols.Cursor.next scan in
Ok (Option.is_some first) )
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 in
Ok
( new ephemeral plan (identity ?pinned plan) declaration (exhaustible declaration BatSet.String.empty) edges
|> Protocols.Handle.make )
end
|
