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
|
module Error = struct
open Concepts.Condition
let unknown_relation name =
condition "unknown-relation" "A plan named a relation that does not exist under this snapshot"
("name" |=| Concepts.Value.String name)
let cancelled () =
condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty
let not_a_plan () =
condition "not-a-fol-program" "The evaluator was given a program of another kind" empty
let unknown_attribute name =
condition "unknown-attribute" "A plan projected an attribute its relation does not have"
("attribute" |=| Concepts.Value.String name)
let malformed_program () =
condition "malformed-fol-program"
"A stored FOL program did not conform to what was expected. Is your database corrupted?" empty
let cyclic_program code =
condition "cyclic-program" "A stored program reads itself"
("program" |=| Concepts.Value.String (Concepts.Hash.to_hum_string code))
end
let name = "fol"
type 'r term = Base of 'r | Project of 'r term * string BatFingerTree.t
type plan = Protocols.Handle.t term
type Kernel.Program.kind += Fol of Kernel.Path.t term
module Bencode = Concepts.Encoding.Bencode
let rec bencode_of_term =
let strings values = Bencode.List (List.map (fun value -> Bencode.String value) values) in
function
| Base path -> Bencode.Tagged ('b', strings (Kernel.Path.to_list path))
| Project (term, attributes) ->
Bencode.Tagged
( 'p',
Bencode.Dict
["term", bencode_of_term term; "attributes", strings (BatFingerTree.to_list attributes)]
)
let rec term_of_bencode =
let open Utilities.Result in
let strings values =
let* values = Bencode.as_list values in
List.map Bencode.as_string values |> Utilities.List.sequence
in
function
| Bencode.Tagged ('b', segments) ->
strings segments |> Result.map (fun segments -> Base (Kernel.Path.of_list segments))
| Bencode.Tagged ('p', data) ->
let* term = Bencode.field "term" data |> fmap term_of_bencode in
let* attributes = Bencode.field "attributes" data |> fmap strings in
Ok (Project (term, BatFingerTree.of_list attributes))
| _ -> Error (Error.malformed_program ())
let encode term = bencode_of_term term |> Bencode.to_bytes |> Bytes.to_string
let decode source = Bencode.of_bytes (Bytes.of_string source) |> Utilities.Result.fmap term_of_bencode
(* TODO: To strenghten our checks for self references, we need to
construct a graph and see raise a condition if there are self
references. We partially do that here with the program calling
self, but if the flow is alternated, say between program A and B,
where B calls A and A calls B, we also must check. *)
let instantiate within =
let open Utilities.Result in
let rec bind expanding = function
| Base reference -> (
let* relation = Kernel.Path.lookup within reference in
match Kernel.Program.image relation with
| None -> Ok (Base relation)
| Some {kind= Fol term; source; _} ->
Protocols.Handle.release relation;
let identity = Concepts.Hash.hash_of_bytes (Bytes.of_string source) in
if List.exists (Concepts.Hash.hash_equals identity) expanding then
Error (Error.cyclic_program identity)
else bind (identity :: expanding) term
| Some _ ->
Protocols.Handle.releasing relation (fun () ->
let* program = Protocols.Executable.require relation in
let* result = Protocols.Executable.invoke program [] ~within in
Ok (Base result) ) )
| Project (term, attributes) ->
let* plan = bind expanding term in
Ok (Project (plan, attributes))
in
bind []
let restrict attributes description =
let open Utilities.Result in
Utilities.FingerTree.foldm_left
(fun restricted name ->
let* attribute =
BatMap.String.find_opt name description
|> Option.to_result ~none:(Error.unknown_attribute name)
in
Ok (BatMap.String.add name attribute restricted) )
BatMap.String.empty attributes
let rec describe =
let open Utilities.Result in
function
| Base relation -> Protocols.Relation.heading relation
| Project (plan, attributes) -> describe plan |> fmap (restrict attributes)
let rec modes =
let open Utilities.Result in
function
| Base relation ->
let* relation = Protocols.Relation.require relation in
Protocols.Relation.modes relation
| Project (plan, attributes) ->
modes plan
|> Result.map
(Concepts.Mode.project (BatSet.String.of_list (BatFingerTree.to_list attributes)))
let project description relation =
let open Utilities.Result in
let* cursor = Protocols.Enumerable.cursor relation in
let produce ~yield =
let* scan = Protocols.Cursor.require cursor in
let rec distinct seen =
let* next = Protocols.Cursor.next scan in
match next with
| None -> Ok ()
| Some tuple ->
let tuple =
{ tuple with
attributes=
BatMap.String.filter
(fun name _ -> BatMap.String.mem name description)
tuple.Concepts.Tuple.attributes }
in
let key = Concepts.Tuple.hash tuple |> Concepts.Hash.to_raw_string in
if BatSet.String.mem key seen then distinct seen
else begin
yield tuple;
distinct (BatSet.String.add key seen)
end
in
distinct BatSet.String.empty
in
Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce)
let contains relation tuple =
Result.bind (Protocols.Relation.require relation) (fun r -> Protocols.Relation.contains r tuple)
let derive ?decide relation description modes enumerate =
Kernel.EphemeralRelation.instantiate ~inputs:[relation] ?decide
~modes:(fun () -> Ok modes)
description
(Kernel.EphemeralRelation.temporary description)
(fun () -> enumerate relation)
let rec execute plan =
let open Utilities.Result in
let* description = describe plan in
let* modes = modes plan in
match plan with
| Base relation ->
let relation = Protocols.Handle.move relation in
Ok (derive ~decide:(contains relation) relation description modes Protocols.Enumerable.cursor)
| Project (plan, _) ->
let* relation = execute plan in
Ok (derive relation description modes (project description))
class evaluator =
object (self)
inherit Kernel.Lifecycle.null
inherit Kernel.Identity.of_id
method to_string = "fol-evaluator"
method parse source = decode source |> Result.map (fun term -> Fol term)
method eval kind _inputs ~within =
let open Utilities.Result in
match kind with
| Fol term ->
let* plan = instantiate within term in
execute plan
| _ -> Error (Error.not_a_plan ())
method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
end
let make () = new evaluator |> Protocols.Handle.make
let program ?root term = Kernel.Program.make ?root ~evaluator:name ~source:(encode term) (Fol term)
|
