`Project` plan node

4 files changed, 62 insertions, 5 deletions

diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml
index 5f820c8..34edc08 100644
--- a/lib/drl/executor.ml
+++ b/lib/drl/executor.ml
@@ -28,10 +28,14 @@ module Make (NT : Nt.S) = struct
         Ok (Nt.Take { limit = n; source = p })
     | Ast.Const _ ->
         Error (Error.unsupported_operator
-          "Const: literal relations not yet reachable by VM; use Base")
+                 "Const: literal relations not yet reachable by VM; use Base")
+    | Ast.Project (attrs, query) ->
+       let* source = compile resolve query in
+       Ok (Nt.Project { attrs; source })
+    | Ast.Rename _ -> Error (Error.unsupported_operator "TODO")
     | _ ->
         Error (Error.unsupported_operator
-          "Select/Project/Rename/Union/Diff/Cartesian require VM operators not yet implemented")
+          "Select/Union/Diff/Cartesian require VM operators not yet implemented")
 
   let page_limit = 16
 
diff --git a/lib/nt.ml b/lib/nt.ml
index 3882288..41de1d0 100644
--- a/lib/nt.ml
+++ b/lib/nt.ml
@@ -33,6 +33,7 @@ type plan_node =
      concrete join algorithm (e.g. HashJoin, NestedLoop, LeapFrog, &c) *)
   | Join of { left : plan_node; right : plan_node; on_attrs : string list }
   | Take of { limit : int; source : plan_node }
+  | Project of { source : plan_node; attrs : string list }
 
 module Error = struct
   open Condition
@@ -326,6 +327,12 @@ module Make (B : Backend) = struct
         (match Nt_ffi.ptr_to_opt raw with
          | None   -> Error (Error.cursor_error "plan_take failed")
          | Some p -> Ok p)
+    | Project { source; attrs } ->
+       Nt_ffi.with_strings_as_char_array attrs (fun attrs ->
+           let* sp = build_plan source in
+           let raw = Nt_ffi.rnt_plan_project (Nt_ffi.nint_to_ptr sp) attrs in
+           Nt_ffi.ptr_to_opt raw
+           |> Option.to_result ~none:(Error.cursor_error "plan_project failed"))
 
   let execute_query (plan : plan_node) ~(rel_name : string) :
       (tuple_stream, Condition.t) result =
diff --git a/lib/nt_ffi.ml b/lib/nt_ffi.ml
index bfbdf65..5937375 100644
--- a/lib/nt_ffi.ml
+++ b/lib/nt_ffi.ml
@@ -151,6 +151,9 @@ let rnt_plan_take source limit =
   setf (plan &-> pa_take) pat_limit limit;
   rnt_plan_assemble plan
 
+let rnt_plan_project =
+  fn "rnt_plan_project" (ptr void @-> ptr (ptr char) @-> returning (ptr void))
+
 let rnt_plan_free =
   fn "rnt_plan_free" (ptr void @-> returning void)
 
@@ -192,6 +195,23 @@ let with_out_string (f : char ptr ptr -> int) : int * string option =
   if is_null p then (rc, None)
   else (rc, Some (consume_cstring p))
 
+let with_strings_as_char_array
+      (strings : string list)
+      (body : char ptr ptr -> 'a)
+    : 'a =
+  let arr =
+    CArray.make
+      ~initial:(from_voidp char null)
+      (ptr char)
+      (1 + List.length strings)
+  in
+  List.iteri
+    (fun i s -> CArray.set arr i (Ctypes_std_views.char_ptr_of_string s))
+    strings;
+  body (CArray.start arr)
+  (* let pp = allocate (ptr (ptr char)) (from_voidp (ptr char) null) in *)
+
+
 (* Converts a void* (returned from open_handle / cursor_open) to nativeint.
    Returns None when the pointer is NULL (failure). *)
 let ptr_to_opt (p : unit ptr) : nativeint option =
diff --git a/test/drl_test.ml b/test/drl_test.ml
index c470f96..26c808d 100644
--- a/test/drl_test.ml
+++ b/test/drl_test.ml
@@ -36,6 +36,17 @@ let seed_fixture
           [("name", Obj.magic "peach"); ("flavour", Obj.magic "sweet")];
           [("name", Obj.magic "grape"); ("flavour", Obj.magic "sweet")];
           [("name", Obj.magic "lemon"); ("flavour", Obj.magic "sour")]
+        ];
+
+      relation
+        ~name:"drink"
+        ~schema:(Schema.empty
+                 |> Schema.add "name" "string"
+                 |> Schema.add "fruit" "string")
+        ~tuples:[
+          [("name", Obj.magic "lemonade");    ("fruit", Obj.magic "lemon")];
+          [("name", Obj.magic "wine");        ("fruit", Obj.magic "grape")];
+          [("name", Obj.magic "grape juice"); ("fruit", Obj.magic "grape")]
         ]
     ]
   in
@@ -70,8 +81,10 @@ module Error = struct
   open Condition
 
   let invalid_argument msg = condition "invalid-argument" msg empty
-  let expected_tuple tuple_expr = condition "expected-tuple" "An expected tuple is missing from the result"
-                                    ("tuple" |=| (of_sexp tuple_expr))
+  let expected_tuple tuple_expr relation_expr =
+    condition "expected-tuple" "An expected tuple is missing from the result"
+      ("tuple" |=| (of_sexp tuple_expr) &
+       "relation" |=| (of_sexp relation_expr))
 end
 
 let assert_ok = function
@@ -88,7 +101,9 @@ let ensure_contains t ts =
   Result.bind ts (fun ts ->
       if contains tuple ts
       then Ok ts
-      else Error (Error.expected_tuple (Tuple.sexp_of_materialized tuple)))
+      else Error (Error.expected_tuple
+                    (Tuple.sexp_of_materialized tuple)
+                    (Sexplib.Sexp.List (List.map Tuple.sexp_of_materialized ts))))
 
 let with_cursor = function
   | Sublanguage_types.Cursor cursor -> Ok (drain cursor)
@@ -105,3 +120,14 @@ let%test_unit "Ensure that `base` translates to a scan over its argument" =
     |> Result.map ignore
   end
   |> assert_ok
+
+let%test_unit "Ensure that `project` returns a projection of it's argument" =
+  begin
+    let* ctx = make_fixture () in
+    let* result = Test_Drl.execute ctx (Drl.Ast.Project (["fruit"], Drl.Ast.Base "fixture:drink")) in
+    with_cursor result
+    |> ensure_contains [("fruit", Obj.magic "grape")]
+    |> ensure_contains [("fruit", Obj.magic "lemon")]
+    |> Result.map ignore
+  end
+  |> assert_ok