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
|
module Error = struct
open Concepts.Condition
let unknown_name name =
condition "unknown-name"
"A term named neither a bound variable nor a relation existing under this snapshot"
("name" |=| Concepts.Value.String name)
let not_applicable () =
condition "not-applicable"
"A term was applied to an argument, but it denotes a relation rather than an abstraction"
empty
let unapplied_abstraction () =
condition "unapplied-abstraction"
"A program reduced to an abstraction, which names no relation to enumerate" empty
let cancelled () =
condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty
end
(* A dummy untyped lambda calculus where constants are relations. We
look for a name in the environment first and resolved through the
context otherwise, so the relations reachable under the snapshot
are the outer environment every program is evaluated on *)
type term =
| Name of string
| Abstract of string * term
| Apply of term * term
type program = Program of term * Protocols.Directory.t Protocols.Handle.interface
module Program = Protocols.Program.Make (struct
type t = program
end)
type value =
| Relation of Protocols.Handle.t
| Closure of string * term * environment
and environment = value BatMap.String.t
(* let reduce context term = *)
(* let open Utilities.Result in *)
(* let rec eval environment term = *)
(* match context.Protocols.Context.status () with *)
(* | `Cancelled | `Exhausted -> Error (Error.cancelled ()) *)
(* | `Live -> *)
(* match term with *)
(* | Name name -> *)
(* begin match BatMap.String.find_opt name environment with *)
(* | Some value -> Ok value *)
(* | None -> *)
(* let* found = Runtime.Context.resolve context name in *)
(* let* handle = Option.to_result ~none:(Error.unknown_name name) found in *)
(* Ok (Relation handle) *)
(* end *)
(* | Abstract (binder, body) -> Ok (Closure (binder, body, environment)) *)
(* | Apply (operator, operand) -> *)
(* let* operator = eval environment operator in *)
(* match operator with *)
(* | Relation _ -> Error (Error.not_applicable ()) *)
(* | Closure (binder, body, closed) -> *)
(* let* argument = eval environment operand in *)
(* eval (BatMap.String.add binder argument closed) body *)
(* in *)
(* eval BatMap.String.empty term *)
let reduce (Program (term, dir)) =
let open Utilities.Result in
let open Protocols in
let rec eval env term =
match term with
| Name name ->
begin
match BatMap.String.find_opt name env with
| Some value -> Ok value
| None ->
let* handle = Directory.find dir name |> fmap (Option.to_result ~none:(Error.unknown_name name)) in
Ok (Relation handle)
end
| Abstract (binder, body) -> Ok (Closure (binder, body, env))
| Apply (operator, operand) ->
let* operator = eval env operator in
match operator with
| Relation _ -> Error (Error.not_applicable ())
| Closure (binder, body, closed) ->
let* argument = eval env operand in
eval (BatMap.String.add binder argument closed) body
in
eval BatMap.String.empty term
let execute term =
let open Utilities.Result in
let* value = reduce term in
match value with
| Closure _ -> Error (Error.unapplied_abstraction ())
| Relation handle ->
let* enumerable = Protocols.Enumerable.require handle in
Protocols.Enumerable.enumerate enumerable
class evaluator = object (self)
inherit Kernel.Lifecycle.null
inherit Kernel.Identity.of_id
method invoke program = execute program
method protocols : Protocols.Handle.protocol list = [Program.make self]
end
let make () = new evaluator |> Protocols.Handle.make
|
