aboutsummaryrefslogtreecommitdiffstats
path: root/lib/evaluators
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/evaluators/FOL.ml118
-rw-r--r--lib/evaluators/Lambda.ml105
2 files changed, 105 insertions, 118 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 4299524..016e3a0 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -7,32 +7,124 @@ module Error = struct
let cancelled () =
condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty
+
+ let not_a_plan name =
+ condition "not-a-fol-program" "The evaluator was given an object that carries no FOL plan"
+ ("object" |=| Concepts.Value.String name)
+
+ let not_a_relation name =
+ condition "not-a-relation" "A plan named an object that does not describe itself as a relation"
+ ("object" |=| Concepts.Value.String name)
+
+ let unknown_attribute name =
+ condition "unknown-attribute" "A plan projected an attribute its relation does not have"
+ ("attribute" |=| Concepts.Value.String name)
+
+ let released_relation name =
+ condition "released-relation" "A plan named a relation that was already released"
+ ("object" |=| Concepts.Value.String name)
end
type plan = Base of Protocols.Handle.t | Project of plan * string BatFingerTree.t
+type Protocols.Handle.protocol += Plan of plan
+
+class program plan =
+ object
+ inherit Kernel.Lifecycle.null
+ inherit Kernel.Identity.of_id
+ method to_string = "fol-program"
+ method protocols : Protocols.Handle.protocol list = [Plan plan]
+ end
-module Program = Protocols.Program.Make (struct
- type t = plan
-end)
+let program plan = new program plan |> Protocols.Handle.make
+
+let restrict attributes description =
+ let open Utilities.Result in
+ BatFingerTree.fold_left
+ (fun restricted name ->
+ let* restricted = restricted in
+ let* attribute =
+ BatMap.String.find_opt name description
+ |> Option.to_result ~none:(Error.unknown_attribute name)
+ in
+ Ok (BatMap.String.add name attribute restricted) )
+ (Ok BatMap.String.empty) attributes
-let execute =
+let rec describe =
let open Utilities.Result in
function
- | Base relation_handle ->
- Fun.protect
- ~finally:(fun () -> Protocols.Handle.release relation_handle)
- (fun () ->
- let* enumerable = Protocols.Enumerable.require relation_handle in
- Protocols.Enumerable.enumerate enumerable )
- | Project (_plan, _attributes) -> failwith "TODO"
+ | Base relation -> (
+ let* schematics = Protocols.Handle.require Protocols.Schematics.from relation in
+ let* description = Protocols.Schematics.describe schematics in
+ match description with
+ | Protocols.Schematics.Relation description -> Ok description
+ | _ -> Error (Error.not_a_relation (Protocols.Handle.to_string relation)) )
+ | Project (plan, attributes) -> describe plan |> fmap (restrict attributes)
+
+let enumerate relation =
+ let open Utilities.Result in
+ let* enumerable = Protocols.Enumerable.require relation in
+ Protocols.Enumerable.enumerate enumerable
+
+let project description relation =
+ let open Utilities.Result in
+ let* cursor = enumerate 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 derive relation description enumerate =
+ Kernel.EphemeralRelation.instantiate ~inputs:[relation] description
+ {Kernel.EphemeralRelation.schematics= `Temporary description}
+ (fun () -> enumerate relation)
+
+let rec execute plan =
+ let open Utilities.Result in
+ let* description = describe plan in
+ match plan with
+ | Base relation ->
+ let* relation =
+ Protocols.Handle.copy relation
+ |> Option.to_result ~none:(Error.released_relation (Protocols.Handle.to_string relation))
+ in
+ Ok (derive relation description enumerate)
+ | Project (plan, _) ->
+ let* relation = execute plan in
+ Ok (derive relation description (project description))
class evaluator =
object (self)
inherit Kernel.Lifecycle.null
inherit Kernel.Identity.of_id
method to_string = "fol-evaluator"
- method invoke = execute
- method protocols : Protocols.Handle.protocol list = [Program.make self]
+
+ method invoke program =
+ Protocols.Handle.into program (function Plan plan -> Some plan | _ -> None)
+ |> Option.to_result ~none:(Error.not_a_plan (Protocols.Handle.to_string program))
+ |> Utilities.Result.fmap (fun plan -> Protocols.Handle.invoke plan execute)
+
+ method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
end
let make () = new evaluator |> Protocols.Handle.make
diff --git a/lib/evaluators/Lambda.ml b/lib/evaluators/Lambda.ml
deleted file mode 100644
index d864ca1..0000000
--- a/lib/evaluators/Lambda.ml
+++ /dev/null
@@ -1,105 +0,0 @@
-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 to_string = "lambda-evaluator"
- method invoke program = execute program
- method protocols : Protocols.Handle.protocol list = [Program.make self]
- end
-
-let make () = new evaluator |> Protocols.Handle.make
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 13:24:29 +0000