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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
type program = {evaluator: string; code: Concepts.Hash.hash}
type t =
{ name: string option;
schematics:
[ `Persisted of Concepts.Hash.hash
| `Temporary of Protocols.Schematics.attribute_description BatMap.String.t ];
program: program option }
module Error = struct
open Concepts.Condition
let malformed_relation () =
condition "malformed-ephemeral-relation"
"The on-disk representation of an ephemeral relation did not conform to what was expected. \
Is your database corrupted?"
empty
let unbound_program name =
condition "unbound-program"
"A relation generated by a program has to be given a state to run within before it is read"
("relation" |=| Concepts.Value.String name)
let undecidable_membership () =
condition "undecidable-membership"
"A relation with no membership test and no end was asked whether it holds a tuple" empty
end
module Persisted = struct
type nonrec t = {name: string; schematics: Concepts.Hash.hash; program: program}
module rec Representation : (Concepts.Encoding.Record.S with type t = t) =
Concepts.Encoding.Record.Make (Body)
and Body : Concepts.Encoding.Record.BODY = struct
type nonrec t = t
let tag = 'E'
let malformed = Error.malformed_relation
let fields {name; schematics; program= {evaluator; code}} =
let open Concepts.Encoding in
[ "name", Field.string name;
"schema", Value.bencode_of_hash schematics;
"evaluator", Field.string evaluator;
"program", Value.bencode_of_hash code ]
let of_fields fields =
let open Utilities.Result in
let open Concepts.Encoding in
let* name = Field.require_string "name" fields in
let* schematics = Bencode.field "schema" fields |> fmap Value.hash_of_bencode in
let* evaluator = Field.require_string "evaluator" fields in
let* code = Bencode.field "program" fields |> fmap Value.hash_of_bencode in
Ok {name; schematics; program= {evaluator; code}}
end
end
(* FIXME: Bring the Persisted/Temporary out to avoid using the
wildcard and optionals *)
let persisted = function
| {name= Some name; schematics= `Persisted schematics; program= Some program} ->
Some {Persisted.name; schematics; program}
| _ -> None
class ephemeral_relation ?program ?decide description value modes enumerate inputs =
object (self)
inherit Lifecycle.counted
inherit Identity.of_id
method to_string = "ephemeral-relation"
val relation : t = value
method destroy = List.iter Protocols.Handle.release inputs
method enumerate : (Protocols.Handle.t, Concepts.Condition.condition) result = enumerate ()
method modes : (Concepts.Mode.t, Concepts.Condition.condition) result = modes ()
method describe () = Ok (Protocols.Schematics.Relation description)
method contains (tuple : Concepts.Tuple.t) =
let open Utilities.Result in
match decide with
| Some decide -> decide tuple
| None ->
let* modes = self#modes in
if not (Concepts.Mode.exhaustible modes BatSet.String.empty) then
Error (Error.undecidable_membership ())
else
let* cursor = self#enumerate in
Protocols.Handle.releasing cursor (fun () ->
let* scan = Protocols.Cursor.require cursor in
Protocols.Cursor.exists scan (fun member ->
Concepts.Hash.hash_equals (Concepts.Tuple.hash member)
(Concepts.Tuple.hash tuple) ) )
method protocols : Protocols.Handle.protocol list =
let protocols =
Protocols.[Relation.make self; Enumerable.make self; Schematics.make self]
@ Option.fold ~none:[] ~some:Protocols.Handle.protocols program
in
match persisted relation with
| None -> protocols
| Some record ->
Protocols.Addressable.make
object
method address = Persisted.Representation.to_blob record |> Concepts.Hash.hash_of_blob
end
:: protocols
end
let instantiate ?(inputs = []) ?program ?decide ~modes description value enumerate =
new ephemeral_relation ?program ?decide description value modes enumerate inputs
|> Protocols.Handle.make
let literal description tuples =
instantiate description
~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length tuples)))])
{name= None; schematics= `Temporary description; program= None}
(fun () -> Ok (Generator.cursor_of (fun ~yield -> List.iter yield tuples; Ok ())))
type binding = {root: Protocols.Handle.t; within: Protocols.Handle.t}
(* The relation a program produced has to outlive the cursor over it. *)
let enumerate_owned relation =
let open Utilities.Result in
let owner =
object
method reference = true
method release = Protocols.Handle.release relation
method is_managed = true
end
in
match
let* enumerable = Protocols.Enumerable.require relation in
Protocols.Enumerable.enumerate enumerable
with
| Error c -> Protocols.Handle.release relation; Error c
| Ok cursor ->
Ok
(Protocols.Handle.make
object
inherit Lifecycle.retaining cursor owner
method to_string = Protocols.Handle.to_string cursor
end )
let asking f relation =
Protocols.Handle.releasing relation (fun () -> Result.bind (Protocols.Relation.require relation) f)
(* What a program generates is known only from the relation it
returns, so reading it, asking its modes and asking for a tuple
all invoke it. *)
let generated ?program ?within name description value =
let invoking f () =
let open Utilities.Result in
match program, within with
| Some program, Some within ->
let* executable = Protocols.Executable.require program in
Result.bind (Protocols.Executable.invoke executable [] ~within) f
| _ -> Error (Error.unbound_program name)
in
instantiate ?program
~decide:(fun tuple -> invoking (asking (fun r -> Protocols.Relation.contains r tuple)) ())
~modes:(invoking (asking Protocols.Relation.modes))
description value (invoking enumerate_owned)
let of_program ?within description program =
generated ~program ?within (Protocols.Handle.to_string program) description
{name= None; schematics= `Temporary description; program= None}
module Make (S : Abstract.Storage.STORAGE) = struct
module SI = Storage.Make (S)
module R = SubstantialRelation.Make (S)
let restore ?program ?within ({Persisted.name; schematics; program= pointer} : Persisted.t)
description =
generated ?program ?within name description
{name= Some name; schematics= `Persisted schematics; program= Some pointer}
let load ?bind connection (record : Persisted.t) =
let open Utilities.Result in
let* description, source =
SI.with_read connection (fun tx ->
let* description = R.schema_of tx record.schematics in
let* code = SI.get_req tx (S.Hash record.program.code) in
Ok (description, Bytes.to_string (Concepts.Blob.bytes_of_blob code)) )
in
match bind with
| None -> Ok (restore record description)
| Some {root; within} ->
let* program = Program.load root ~evaluator:record.program.evaluator ~source in
Ok (restore ~program ~within record description)
let store tx ~name ~evaluator ~source description =
let open Utilities.Result in
let* schematics = R.store_schema tx description in
let* address = SI.store_blob tx (Concepts.Blob.blob_of_bytes (Bytes.of_string source)) in
let record = {Persisted.name; schematics; program= {evaluator; code= address}} in
let* _ = SI.store_blob tx (Persisted.Representation.to_blob record) in
Ok record
let persist connection ~name program description =
let open Utilities.Result in
let* {Program.evaluator; source; _} = Program.require program in
SI.with_transaction connection (fun tx ->
let* record = store tx ~name ~evaluator ~source description in
Ok (restore ~program record description) )
end
|
