clearer names in fol, merging restrictions as they sink

1 files changed, 37 insertions, 28 deletions

diff --git a/lib/evaluators/FOL.ml b/lib/evaluators/FOL.ml
index 60cc89f..e28222b 100644
--- a/lib/evaluators/FOL.ml
+++ b/lib/evaluators/FOL.ml
@@ -90,14 +90,28 @@ let decode source = Utilities.Result.(Bencode.of_bytes (Bytes.of_string source)
 let bound binding = BatSet.String.of_enum (BatMap.String.keys binding)
 let names attributes = BatSet.String.of_list (BatFingerTree.to_list attributes)
 
+let merge outer inner =
+  BatMap.String.fold
+    (fun name value merged ->
+      Option.bind merged (fun merged ->
+          match BatMap.String.find_opt name merged with
+          | None -> Some (BatMap.String.add name value merged)
+          | Some held -> if Concepts.Value.equal value held then Some merged else None ) )
+    outer (Some inner)
+
+let rec sink binding = function
+  | Project (term, attributes) when BatSet.String.subset (bound binding) (names attributes) ->
+      Project (sink binding term, attributes)
+  | Where (term, inner) as restricted -> (
+    match merge binding inner with
+    | Some merged -> Where (term, merged)
+    | None -> Where (restricted, binding) )
+  | term -> Where (term, binding)
+
 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) )
+  | Where (term, binding) -> sink binding (push term)
 
 (* TODO: To strenghten our checks for self references, we need to
    construct a graph and see raise a condition if there are self
@@ -131,26 +145,22 @@ let instantiate within =
   in
   fun term -> bind [] term |> Result.map push
 
-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 known heading names =
+  match List.find_opt (fun name -> not (BatMap.String.mem name heading)) names with
+  | Some name -> Error (Error.unknown_attribute name)
+  | None -> Ok heading
+
+let subheading attributes heading =
+  known heading (BatFingerTree.to_list attributes)
+  |> Result.map (BatMap.String.filter (fun name _ -> BatSet.String.mem name (names attributes)))
 
 let rec describe =
   let open Utilities.Result in
   function
   | Base relation -> Protocols.Relation.heading relation
-  | Project (plan, attributes) -> describe plan |>> restrict attributes
+  | Project (plan, attributes) -> describe plan |>> subheading attributes
   | Where (plan, binding) ->
-      let* heading = describe plan in
-      let* _ = restrict (BatFingerTree.of_enum (BatMap.String.keys binding)) heading in
-      Ok heading
+      describe plan |>> fun heading -> known heading (BatSet.String.elements (bound binding))
 
 let index_for relation binding =
   let open Utilities.Option in
@@ -168,14 +178,13 @@ let rec modes =
       Protocols.Relation.modes relation
   | Project (plan, attributes) ->
       modes plan |> Result.map (Concepts.Mode.project (names attributes))
-  | Where (plan, binding) -> (
+  | Where (plan, binding) ->
       let* modes = modes plan in
-      match plan with
-      | Base relation -> (
-        match index_for relation binding with
-        | Some (_, attribute) -> Ok (Concepts.Mode.given attribute modes)
-        | None -> Ok modes )
-      | _ -> Ok modes )
+      let index = match plan with Base relation -> index_for relation binding | _ -> None in
+      Ok
+        (Option.fold ~none:modes
+           ~some:(fun (_, attribute) -> Concepts.Mode.given attribute modes)
+           index )
 
 let project description relation =
   let open Utilities.Result in
@@ -212,7 +221,7 @@ let agrees binding {Concepts.Tuple.attributes; _} =
         (BatMap.String.find_opt name attributes) )
     binding
 
-let restricted binding relation =
+let restriction binding relation =
   let open Utilities.Result in
   let* cursor =
     match index_for relation binding with
@@ -252,7 +261,7 @@ let rec execute plan =
       Ok
         (derive
            ~decide:(fun tuple -> if agrees binding tuple then contains relation tuple else Ok false)
-           relation description modes (restricted binding) )
+           relation description modes (restriction binding) )
 
 class evaluator =
   object (self)