diff options
| -rw-r--r-- | lib/drl/executor.ml | 8 | ||||
| -rw-r--r-- | lib/nt.ml | 7 | ||||
| -rw-r--r-- | lib/nt_ffi.ml | 20 | ||||
| -rw-r--r-- | test/drl_test.ml | 32 |
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 @@ -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 |