diff options
Diffstat (limited to 'lib/evaluators')
| -rw-r--r-- | lib/evaluators/FOL.ml | 96 |
1 files changed, 90 insertions, 6 deletions
diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml index f337d61..1064c74 100644 --- a/lib/evaluators/FOL.ml +++ b/lib/evaluators/FOL.ml @@ -12,7 +12,7 @@ module Error = struct 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" + condition "unknown-attribute" "A plan named an attribute its relation does not have" ("attribute" |=| Concepts.Value.String name) let malformed_program () = @@ -26,7 +26,13 @@ end let name = "fol" -type 'r term = Base of 'r | Project of 'r term * string BatFingerTree.t +type binding = Concepts.Value.value BatMap.String.t + +type 'r term = + | Base of 'r + | Project of 'r term * string BatFingerTree.t + | Where of 'r term * binding + type plan = Protocols.Handle.t term type Kernel.Program.kind += Fol of Kernel.Path.t term @@ -42,6 +48,16 @@ let rec bencode_of_term = Bencode.Dict ["term", bencode_of_term term; "attributes", strings (BatFingerTree.to_list attributes)] ) + | Where (term, binding) -> + Bencode.Tagged + ( 'w', + Bencode.Dict + [ "term", bencode_of_term term; + ( "binding", + Bencode.Dict + ( BatMap.String.bindings binding + |> List.map (fun (name, value) -> name, Concepts.Tuple.bencode_of_value value) ) ) + ] ) let rec term_of_bencode = let open Utilities.Result in @@ -56,10 +72,32 @@ let rec term_of_bencode = let* term = Bencode.field "term" data |>> term_of_bencode in let* attributes = Bencode.field "attributes" data |>> strings in Ok (Project (term, BatFingerTree.of_list attributes)) + | Bencode.Tagged ('w', data) -> + let* term = Bencode.field "term" data |>> term_of_bencode in + let* binding = Bencode.field "binding" data |>> Bencode.as_dict in + let* binding = + List.map + (fun (name, value) -> + Concepts.Tuple.value_of_bencode value |> Result.map (fun value -> name, value) ) + binding + |> Utilities.List.sequence + in + Ok (Where (term, BatMap.String.of_list binding)) | _ -> Error (Error.malformed_program ()) let encode term = bencode_of_term term |> Bencode.to_bytes |> Bytes.to_string let decode source = Utilities.Result.(Bencode.of_bytes (Bytes.of_string source) |>> term_of_bencode) +let bound binding = BatSet.String.of_enum (BatMap.String.keys binding) +let names attributes = BatSet.String.of_list (BatFingerTree.to_list attributes) + +let rec push = function + | Base relation -> Base relation + | Project (term, attributes) -> Project (push term, attributes) + | Where (term, binding) -> ( + match push term with + | Project (term, attributes) when BatSet.String.subset (bound binding) (names attributes) -> + Project (push (Where (term, binding)), attributes) + | term -> Where (term, binding) ) (* TODO: To strenghten our checks for self references, we need to construct a graph and see raise a condition if there are self @@ -87,8 +125,11 @@ let instantiate within = | Project (term, attributes) -> let* plan = bind expanding term in Ok (Project (plan, attributes)) + | Where (term, binding) -> + let* plan = bind expanding term in + Ok (Where (plan, binding)) in - bind [] + fun term -> bind [] term |> Result.map push let restrict attributes description = let open Utilities.Result in @@ -106,6 +147,18 @@ let rec describe = function | Base relation -> Protocols.Relation.heading relation | Project (plan, attributes) -> describe plan |>> restrict attributes + | Where (plan, binding) -> + let* heading = describe plan in + let* _ = restrict (BatFingerTree.of_enum (BatMap.String.keys binding)) heading in + Ok heading + +let index_for relation binding = + let open Utilities.Option in + let* indexed = Protocols.Indexed.from relation in + let* attribute = + List.find_opt (fun a -> BatMap.String.mem a binding) (Protocols.Indexed.indexes indexed) + in + Some (indexed, attribute) let rec modes = let open Utilities.Result in @@ -114,9 +167,13 @@ let rec modes = 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))) + modes plan |> Result.map (Concepts.Mode.project (names attributes)) + | Where (plan, binding) -> ( + let* modes = modes plan in + match plan with + | Base relation when Option.is_some (index_for relation binding) -> + Ok (Concepts.Mode.given (bound binding) modes) + | _ -> Ok modes ) let project description relation = let open Utilities.Result in @@ -146,6 +203,23 @@ let project description relation = in Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce) +let agrees binding {Concepts.Tuple.attributes; _} = + BatMap.String.for_all + (fun name value -> + Option.fold ~none:false ~some:(Concepts.Value.equal value) + (BatMap.String.find_opt name attributes) ) + binding + +let restricted binding relation = + let open Utilities.Result in + let* cursor = + match index_for relation binding with + | Some (indexed, attribute) -> + Protocols.Indexed.lookup indexed attribute (BatMap.String.find attribute binding) + | None -> Protocols.Enumerable.cursor relation + in + Ok (Kernel.Generator.filter (agrees binding) cursor) + let contains relation tuple = Result.bind (Protocols.Relation.require relation) (fun r -> Protocols.Relation.contains r tuple) @@ -167,6 +241,16 @@ let rec execute plan = | Project (plan, _) -> let* relation = execute plan in Ok (derive relation description modes (project description)) + | Where (plan, binding) -> + let* relation = + match plan with + | Base relation -> Ok (Protocols.Handle.move relation) + | plan -> execute plan + in + Ok + (derive + ~decide:(fun tuple -> if agrees binding tuple then contains relation tuple else Ok false) + relation description modes (restricted binding) ) class evaluator = object (self) |