From 97960adb8426e5270fe16b027e82a2c61674f821 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Mon, 27 Apr 2026 23:24:19 -0300 Subject: Foreign call PRL (#67) --- docs/foreign-call.org | 82 +++++++++++++++++ http_demo_commands.sexp | 4 + lib/algebra.ml | 204 ++++++++++++++++++++++++++++------------- lib/catalog.ml | 34 ++++++- lib/conventions.ml | 12 ++- lib/dcl/sublanguage.ml | 2 +- lib/ddl/sublanguage.ml | 2 +- lib/dml/sublanguage.ml | 2 +- lib/drl/executor.ml | 39 ++++---- lib/dune | 2 + lib/icl/sublanguage.ml | 2 +- lib/listener.ml | 6 +- lib/management/branch.ml | 2 + lib/manipulation.ml | 9 +- lib/prelude/catalog.ml | 56 +++++++++++ lib/prelude/standard.ml | 5 + lib/prl/ast.ml | 16 ++++ lib/prl/executor.ml | 83 +++++++++++++++++ lib/prl/parser.ml | 12 +++ lib/prl/runtime.ml | 84 +++++++++++++++++ lib/prl/sublanguage.ml | 21 +++++ lib/relation.ml | 7 +- lib/scl/sublanguage.ml | 2 +- lib/sublanguage_types.ml | 4 +- prl_api/dune | 3 + prl_api/sakura_prl_api.ml | 32 +++++++ run_tcp.ps1 | 175 +++++++++++++++++++++++++++++++++++ test/test_relational_engine.ml | 70 ++++++++++++++ 28 files changed, 868 insertions(+), 104 deletions(-) create mode 100644 docs/foreign-call.org create mode 100644 http_demo_commands.sexp create mode 100644 lib/prl/ast.ml create mode 100644 lib/prl/executor.ml create mode 100644 lib/prl/parser.ml create mode 100644 lib/prl/runtime.ml create mode 100644 lib/prl/sublanguage.ml create mode 100644 prl_api/dune create mode 100644 prl_api/sakura_prl_api.ml create mode 100644 run_tcp.ps1 diff --git a/docs/foreign-call.org b/docs/foreign-call.org new file mode 100644 index 0000000..31f11fd --- /dev/null +++ b/docs/foreign-call.org @@ -0,0 +1,82 @@ +#+TITLE: Foreign Calls — Invoking OCaml from the Query Layer + +Foreign calls let you expose arbitrary OCaml functions as first-class +relations that can be queried with DRL. The mechanism has two halves: a +plugin (a ~.cmxs~ shared library that registers implementations) and PRL +commands that load the library and bind a named relation to a specific +symbol. + +* How it works + +1. An OCaml plugin is compiled as a shared library and linked against + ~sakura-prl-api~. It registers one or more ~implementation~ values + under string keys via ~Sakura_prl_api.register~. + +2. ~(LoadLibrary "/path/to/plugin.cmxs")~ loads the shared library at + runtime via ~Dynlink~, executing the registration side-effects. + +3. ~(DefineFunctionPredicate ...)~ looks up a registered symbol, builds a + ~Generator.t~ and a membership-criteria function from it, and creates an + immutable relation in the database backed by those functions. + +4. The new relation is then queryable like any stored relation. DRL + operators such as ~Base~, ~Select~, and ~Join~ drive the generator, + which calls into the OCaml implementation on demand. + +* PRL syntax reference + +#+begin_src sexp +(prl (LoadLibrary "/abs/path/plugin.cmxs")) + +(prl (DefineFunctionPredicate + ((name "ns:rel-name") + (schema ((attr1 "string") (attr2 "string"))) + (symbol "registered-key") + (purity Pure) + (cardinality ConstrainedFinite)))) + +(prl ListFunctionPredicates) +#+end_src + +~purity~ is informational (~Pure~ / ~Impure~). ~cardinality~ shapes +planner behaviour: ~ConstrainedFinite~ signals the relation is finite when +given bindings, ~AlephZero~ / ~Continuum~ for open-ended generators. + +* Plugin API + +An ~implementation~ exposes two optional hooks: + +| Field | Type | Role | +|----------------------+-----------------------------------------------------------------+-------------------------------| +| ~produce~ | ~tuple list -> (tuple list, string) result~ (wrapped in option) | Generate rows given bindings | +| ~membership_criteria~| ~tuple -> (bool, string) result~ (wrapped in option) | Test if a specific row holds | + +Both receive and return ~Sakura_prl_api.tuple = (string * Obj.t) list~. +The runtime bridges between these rows and ~Tuple.materialized~ values. + +* Example: HTTP relation + +#+begin_src sexp +; Load the plugin +(prl (LoadLibrary "/path/to/http_plugin.cmxs")) + +; Bind the symbol to a relation +(prl (DefineFunctionPredicate + ((name "http.get") + (schema ((url "string") (status_code "string") (body "string"))) + (symbol "http.get") + (purity Impure) + (cardinality ConstrainedFinite)))) + +; Query it — binds url, fetches, returns status_code + body +(drl (Join (url) (Const (("url" (Str "https://json.org/example.html")))) + (Base "public:http.get"))) +#+end_src + +* See also + +- ~lib/prl/~ — AST, parser, executor for PRL statements +- ~lib/prl/runtime.ml~ — ~Dynlink~ loading and generator/membership bridges +- ~lib/prl/ast.ml~ — ~function_predicate~ record definition +- ~sakura-prl-api/~ — the plugin-facing registration API +- ~http_demo_commands.sexp~ — worked example diff --git a/http_demo_commands.sexp b/http_demo_commands.sexp new file mode 100644 index 0000000..680831f --- /dev/null +++ b/http_demo_commands.sexp @@ -0,0 +1,4 @@ +(prl (LoadLibrary "C:/Users/mague/source/repos/_build/default/plugin/lib/plugin.cmxs")) +(prl (DefineFunctionPredicate ((name "http.get") (schema (("url" "string") ("status_code" "string") ("body" "string"))) (symbol "http.get") (purity Pure) (cardinality ConstrainedFinite)))) +(drl (Select (Const (("url" (Str "https://example.com")))) (Base "public:http.get"))) +(drl (Join (url) (Const (("url" (Str "https://json.org/example.html")))) (Base "public:http.get"))) diff --git a/lib/algebra.ml b/lib/algebra.ml index d8e766f..d1eb26f 100644 --- a/lib/algebra.ml +++ b/lib/algebra.ml @@ -47,6 +47,7 @@ module Make (Storage : Management.Physical.S) = struct ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "derived") + () let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : Relation.t = @@ -170,80 +171,153 @@ module Make (Storage : Management.Physical.S) = struct ~schema:new_schema ?constraints:renamed_constraints lazy_gen) let equijoin storage (attrs : string list) left right = - let right_gen = to_generator storage right in - match drain right_gen with - | Error e -> Error e - | Ok right_tuples -> + let get_vals attr_list = function + | Tuple.Materialized t -> + List.map + (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) + attr_list + | _ -> List.map (fun _ -> None) attr_list + in + let merge lt rt = + match (lt, rt) with + | Tuple.Materialized l, Tuple.Materialized r -> + Tuple.Materialized + { + l with + attributes = + Tuple.AttributeMap.union + (fun _ a _ -> Some a) + l.Tuple.attributes r.Tuple.attributes; + } + | _ -> lt + in + let merged_schema = + left.Relation.schema + @ List.filter + (fun (n, _) -> + (not (List.mem n attrs)) + && not (List.exists (fun (m, _) -> m = n) left.Relation.schema)) + right.Relation.schema + in + let merged_constraints = + match (left.Relation.constraints, right.Relation.constraints) with + | None, None -> None + | Some cs, None | None, Some cs -> Some cs + | Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2) + in + let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in + let rec chain_with_cont g cont pos = + match g pos with + | Generator.Done -> cont pos + | Generator.Value (t, next) -> + Generator.Value (t, fun p -> chain_with_cont next cont p) + | Generator.Error e -> Generator.Error e + in + let make_join_gen left_gen right_tuples = + let rec from_left lgen lpos = + fun pos -> + match lgen (Some lpos) with + | Generator.Done -> Generator.Done + | Generator.Error e -> Generator.Error e + | Generator.Value (lt, next_left) -> ( + let lv = get_vals attrs lt in + let matches = + List.filter_map + (fun rt -> + if get_vals attrs rt = lv then Some (merge lt rt) + else None) + right_tuples + in + match matches with + | [] -> from_left next_left (lpos + 1) pos + | _ -> + chain_with_cont (list_generator matches) + (from_left next_left (lpos + 1)) + pos) + in + from_left left_gen 0 + in + let bindings_of_tuple attrs_list = function + | Tuple.Materialized m -> + List.filter_map + (fun attr -> + match Tuple.AttributeMap.find_opt attr m.Tuple.attributes with + | Some a -> Some (attr, a.Attribute.value) + | None -> None) + attrs_list + | _ -> [] + in + match right.Relation.producer with + | Some right_producer when attrs <> [] -> + (* Right is a function predicate: for each left tuple, call the producer + with that tuple's join-attribute bindings to obtain matching right rows. *) let left_gen = to_generator storage left in - let get_vals attr_list = function - | Tuple.Materialized t -> - List.map - (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) - attr_list - | _ -> List.map (fun _ -> None) attr_list - in - let merge lt rt = - match (lt, rt) with - | Tuple.Materialized l, Tuple.Materialized r -> - Tuple.Materialized - { - l with - attributes = - Tuple.AttributeMap.union - (fun _ a _ -> Some a) - l.Tuple.attributes r.Tuple.attributes; - } - | _ -> lt - in - let merged_schema = - left.Relation.schema - @ List.filter - (fun (n, _) -> - (not (List.mem n attrs)) - && not (List.exists (fun (m, _) -> m = n) left.Relation.schema)) - right.Relation.schema - in - let join_gen = - let rec chain_with_cont g cont pos = - match g pos with - | Generator.Done -> cont pos - | Generator.Value (t, next) -> - Generator.Value (t, fun p -> chain_with_cont next cont p) - | Generator.Error e -> Generator.Error e - in + let make_right_producer_join_gen lgen = let rec from_left lgen lpos = - fun pos -> + fun _pos -> match lgen (Some lpos) with | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e - | Generator.Value (lt, next_left) -> ( - let lv = get_vals attrs lt in - let matches = - List.filter_map - (fun rt -> - if get_vals attrs rt = lv then Some (merge lt rt) - else None) - right_tuples - in - match matches with - | [] -> from_left next_left (lpos + 1) pos - | _ -> - chain_with_cont (list_generator matches) - (from_left next_left (lpos + 1)) - pos) + | Generator.Value (lt, next_left) -> + let bindings = bindings_of_tuple attrs lt in + (match drain (right_producer bindings) with + | Error (GeneratorError e | StorageError e) -> Generator.Error e + | Ok right_tuples -> + let lv = get_vals attrs lt in + let matches = + List.filter_map + (fun rt -> + if get_vals attrs rt = lv then Some (merge lt rt) + else None) + right_tuples + in + (match matches with + | [] -> from_left next_left (lpos + 1) _pos + | _ -> + chain_with_cont (list_generator matches) + (from_left next_left (lpos + 1)) + _pos)) in - from_left left_gen 0 - in - let merged_constraints = - match (left.Relation.constraints, right.Relation.constraints) with - | None, None -> None - | Some cs, None | None, Some cs -> Some cs - | Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2) + from_left lgen 0 in - let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in Ok (of_generator ~name ~schema:merged_schema - ?constraints:merged_constraints join_gen) + ?constraints:merged_constraints + (make_right_producer_join_gen left_gen)) + | _ -> + let right_gen = to_generator storage right in + (match drain right_gen with + | Error e -> Error e + | Ok right_tuples -> + let left_gen_result = + match left.Relation.producer with + | Some left_producer when attrs <> [] -> + (* Left is a function predicate: collect all left tuples by + calling the producer once per unique binding set from right. *) + let unique_bindings = + right_tuples + |> List.filter_map (fun rt -> + let b = bindings_of_tuple attrs rt in + if List.length b = List.length attrs then Some b + else None) + |> List.sort_uniq compare + in + List.fold_left + (fun acc bindings -> + Result.bind acc (fun ts -> + match drain (left_producer bindings) with + | Ok new_ts -> Ok (ts @ new_ts) + | Error e -> Error e)) + (Ok []) + unique_bindings + |> Result.map list_generator + | _ -> Ok (to_generator storage left) + in + Result.bind left_gen_result (fun left_gen -> + Ok + (of_generator ~name ~schema:merged_schema + ?constraints:merged_constraints + (make_join_gen left_gen right_tuples)))) let union storage rel1 rel2 = let gen1 = to_generator storage rel1 in diff --git a/lib/catalog.ml b/lib/catalog.ml index be54375..74fe3de 100644 --- a/lib/catalog.ml +++ b/lib/catalog.ml @@ -33,13 +33,39 @@ module Make (S : Management.Physical.S with type error = string) = struct if Atomic.compare_and_set catalog.multigroups expected updated then Ok () else Error "Concurrent multigroup map update detected" + let get_string_attr attr (t : Tuple.materialized) = + Option.map + (fun a -> (Obj.magic a.Attribute.value : string)) + (Tuple.AttributeMap.find_opt attr t.attributes) + + (** Dynlink every library recorded in public:loaded_library. No-op on a fresh + DB; effective when loading a previously persisted multigroup. *) + let hydrate_prl_libraries storage (db : Management.Database.t) = + match + Management.Database.get_relation db Prelude.Catalog.loaded_library_rel_name + with + | None -> () + | Some rel -> + let hashes = + match rel.Relation.tree with None -> [] | Some t -> Merkle.keys t + in + (match Manip.load_tuples storage hashes with + | Error _ -> () + | Ok tuples -> + List.iter + (fun t -> + match get_string_attr "path" t with + | None -> () + | Some path -> ignore (Prl.Runtime.load_library path)) + tuples) + (** Swallow errors: a missing prelude relation is non-fatal. *) let register_prelude_relation storage db (rel : Relation.t) = match Manip.create_immutable_relation storage db ~name:rel.name ~schema:rel.schema ~generator:(Option.get rel.generator) ~membership_criteria:rel.membership_criteria - ~cardinality:rel.cardinality + ~cardinality:rel.cardinality ~producer:None with | Ok (new_db, _) -> new_db | Error e -> @@ -47,10 +73,12 @@ module Make (S : Management.Physical.S with type error = string) = struct rel.name (Sexplib.Sexp.to_string (Error.sexp_of_error e)); db - (** Create DB + seed catalog + fold in [prelude_relations]. *) + (** Create DB + seed catalog + fold in [prelude_relations] + hydrate PRL. *) let bootstrap_multigroup storage ~prelude_relations ~name = let* db = Manip.create_database storage ~name |> map_error in - Ok (List.fold_left (register_prelude_relation storage) db prelude_relations) + let db = List.fold_left (register_prelude_relation storage) db prelude_relations in + hydrate_prl_libraries storage db; + Ok db (** Create additional catalog relations beyond the base six. Used to seed [public:multigroup] into the sakura multigroup only. *) diff --git a/lib/conventions.ml b/lib/conventions.ml index 93dd579..cdc63a9 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -13,13 +13,15 @@ module Name = struct end module Cardinality = struct + open Sexplib.Std + type t = Finite of int | ConstrainedFinite | AlephZero | Continuum + [@@deriving sexp] +end - let sexp_of_t = function - | Finite n -> Sexplib.Sexp.(List [ Atom "Finite"; Atom (string_of_int n) ]) - | ConstrainedFinite -> Sexplib.Sexp.Atom "ConstrainedFinite" - | AlephZero -> Sexplib.Sexp.Atom "AlephZero" - | Continuum -> Sexplib.Sexp.Atom "Continuum" +module Purity = struct + type t = Pure | IO + [@@deriving sexp] end module AbstractValue = struct diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml index 7af0703..ecd2e60 100644 --- a/lib/dcl/sublanguage.ml +++ b/lib/dcl/sublanguage.ml @@ -16,7 +16,7 @@ module Make (Storage : Management.Physical.S with type error = string) = struct let execute storage db ast = match Exec.execute storage db ast with - | Ok (Exec.DbResult (db, msg)) -> Ok (Sublanguage_types.Transition (db, msg)) + | Ok (Exec.DbResult (db, _)) -> Ok (Sublanguage_types.Transition db) | Ok (Exec.Switch multigroup) -> Ok (Sublanguage_types.SessionSwitch multigroup) | Ok (Exec.NewMultigroup name) -> Ok (Sublanguage_types.CreateMultigroup name) | Error e -> Error e diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml index f5ff8f9..b1c87e5 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -16,7 +16,7 @@ module Make (Storage : Management.Physical.S) = struct let execute storage db ast = match Exec.execute storage db ast with - | Ok (db, msg) -> Ok (Sublanguage_types.Transition (db, msg)) + | Ok (db, _) -> Ok (Sublanguage_types.Transition db) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index 45b5a79..cc9d200 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -16,7 +16,7 @@ module Make (Storage : Management.Physical.S) = struct let execute storage db ast = match Exec.execute storage db ast with - | Ok db -> Ok (Sublanguage_types.Transition (db, "updated")) + | Ok db -> Ok (Sublanguage_types.Transition db) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index f1732eb..3ff4553 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -20,6 +20,19 @@ module Make (Storage : Management.Physical.S) = struct let wrap = Result.map_error (fun e -> AlgebraError e) let ast_value_to_abstract = Ast.value_to_abstract + let select_semijoin storage source filter = + let common = + List.filter_map + (fun (n, _) -> + if List.exists (fun (m, _) -> m = n) filter.Relation.schema + then Some n + else None) + source.Relation.schema + in + let source_attrs = List.map fst source.Relation.schema in + Result.bind (wrap (Alg.equijoin storage common source filter)) (fun joined -> + wrap (Alg.project storage source_attrs joined)) + let rec execute (storage : Storage.t) (db : Management.Database.t) (q : Ast.query) : (Relation.t, error) Result.t = let ( >>= ) = Result.bind in @@ -35,40 +48,32 @@ module Make (Storage : Management.Physical.S) = struct | Ast.Select (filter_q, source_q) -> execute storage db filter_q >>= fun filter -> execute storage db source_q >>= fun source -> - (* semijoin = project(source attrs, equijoin on common attrs) *) - let common = - List.filter_map - (fun (n, _) -> - if List.exists (fun (m, _) -> m = n) filter.Relation.schema then - Some n - else None) - source.Relation.schema - in - let source_attrs = List.map fst source.Relation.schema in - wrap (Alg.equijoin storage common source filter) >>= fun joined -> - wrap (Alg.project storage source_attrs joined) + select_semijoin storage source filter | Ast.Join (attrs, q1, q2) -> execute storage db q1 >>= fun r1 -> execute storage db q2 >>= fun r2 -> wrap (Alg.equijoin storage attrs r1 r2) | Ast.Project (attrs, q) -> - execute storage db q >>= fun rel -> wrap (Alg.project storage attrs rel) + execute storage db q >>= fun rel -> + wrap (Alg.project storage attrs rel) | Ast.Rename (renames, q) -> execute storage db q >>= fun rel -> wrap (Alg.rename storage renames rel) | Ast.Cartesian (q1, q2) -> execute storage db q1 >>= fun r1 -> execute storage db q2 >>= fun r2 -> - (* Cartesian product = join on no attrs *) wrap (Alg.equijoin storage [] r1 r2) | Ast.Union (q1, q2) -> execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> wrap (Alg.union storage r1 r2) + execute storage db q2 >>= fun r2 -> + wrap (Alg.union storage r1 r2) | Ast.Diff (q1, q2) -> execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> wrap (Alg.diff storage r1 r2) + execute storage db q2 >>= fun r2 -> + wrap (Alg.diff storage r1 r2) | Ast.Take (n, q) -> - execute storage db q >>= fun rel -> wrap (Alg.take storage n rel) + execute storage db q >>= fun rel -> + wrap (Alg.take storage n rel) end module Memory = Make (Management.Physical.Memory) diff --git a/lib/dune b/lib/dune index 165ef24..9a7cd0b 100644 --- a/lib/dune +++ b/lib/dune @@ -4,6 +4,8 @@ (name relational_engine) (public_name sakura.relational_engine) (libraries + dynlink + sakura_prl_api sha data-encoding lwt diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index fdf17b3..c415d96 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -16,7 +16,7 @@ module Make (Storage : Management.Physical.S) = struct let execute storage db ast = match Exec.execute storage db ast with - | Ok (db, msg) -> Ok (Sublanguage_types.Transition (db, msg)) + | Ok (db, _) -> Ok (Sublanguage_types.Transition db) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error diff --git a/lib/listener.ml b/lib/listener.ml index c706180..9d0e67b 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -34,6 +34,7 @@ functor (module Dml.Sublanguage.Make (S) : SubS); (module Icl.Sublanguage.Make (S) : SubS); (module Dcl.Sublanguage.Make (S) : SubS); + (module Prl.Sublanguage.Make (S) : SubS); (module Scl.Sublanguage.Make (S) : SubS); ] Utilities.StringMap.empty @@ -63,7 +64,7 @@ functor let perform storage catalog ctx db_head old_db result = match result with - | Sublanguage.Transition (new_db, _) -> + | Sublanguage.Transition new_db -> if Atomic.compare_and_set db_head old_db new_db then ( advance_head_branch storage new_db.hash; Ok result) @@ -168,11 +169,10 @@ functor List [ Atom "db_name"; Atom db.name ]; List [ Atom "branch"; Atom (get_branch storage) ]; ] - | Ok (Sublanguage.Transition (new_db, message)) -> + | Ok (Sublanguage.Transition new_db) -> List [ Atom "ok"; - List [ Atom "message"; Atom message ]; List [ Atom "db_hash"; Atom new_db.hash ]; List [ Atom "db_name"; Atom new_db.name ]; (* TODO: `serialize' shouldn't need access to the storage layer *) diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 81dcdff..4485b35 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -103,6 +103,7 @@ module Make (Storage : Physical.S with type error = string) = struct ~membership_criteria:(fun _ _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name) ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) + () let head_relation storage : Relation.t = let schema = Schema.empty |> Schema.add "branch" "string" in @@ -130,4 +131,5 @@ module Make (Storage : Physical.S with type error = string) = struct ~membership_criteria:(fun _ _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name) ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) + () end diff --git a/lib/manipulation.ml b/lib/manipulation.ml index acf6068..31e6079 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -253,6 +253,7 @@ module Make (Storage : Management.Physical.S) = struct (build_membership_criteria ~name:stored.name stored.schema) ~provenance:(Relation.Provenance.Base stored.name) ~lineage:(Relation.Lineage.Base stored.name) + () in Ok (Some relation) @@ -319,6 +320,7 @@ module Make (Storage : Management.Physical.S) = struct ~membership_criteria:(build_membership_criteria ~name schema) ~provenance:(Relation.Provenance.Base name) ~lineage:(Relation.Lineage.Base name) + () in let new_db = Management.Database.add_relation db ~relation in let* () = store_relation storage relation in @@ -845,6 +847,7 @@ module Make (Storage : Management.Physical.S) = struct ~membership_criteria:(build_membership_criteria ~name schema) ~provenance:(Relation.Provenance.Base name) ~lineage:(Relation.Lineage.Base name) + () in let new_db = Management.Database.add_relation db ~relation in let* () = store_relation storage relation in @@ -856,7 +859,8 @@ module Make (Storage : Management.Physical.S) = struct let create_immutable_relation (storage : storage) (db : Management.Database.t) ~(name : string) ~(schema : Schema.t) ~(generator : Generator.t) ~(membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool) - ~(cardinality : Conventions.Cardinality.t) : + ~(cardinality : Conventions.Cardinality.t) + ~(producer : Relation.producer option) : (Management.Database.t * Relation.t, error) Result.t = let name = normalize_name name in if Management.Database.has_relation db name then @@ -869,8 +873,9 @@ module Make (Storage : Management.Physical.S) = struct Relation.make ~hash:(Some relation_hash) ~name ~schema ~tree:None (* No tree for generator-based relations *) ~constraints:None ~cardinality ~generator:(Some generator) - ~membership_criteria ~provenance:(Relation.Provenance.Base name) + ~producer ~membership_criteria ~provenance:(Relation.Provenance.Base name) ~lineage:(Relation.Lineage.Base name) + () in let new_db = Management.Database.add_relation db ~relation in let* () = store_relation storage relation in diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml index 743d397..4b89b4a 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -18,6 +18,8 @@ let branch_rel_name = catalog_prefix ^ "branch" let head_rel_name = catalog_prefix ^ "head" let multigroup_rel_name = catalog_prefix ^ "multigroup" let schema_rel_name = catalog_prefix ^ "schema" +let function_predicate_rel_name = catalog_prefix ^ "function_predicate" +let loaded_library_rel_name = catalog_prefix ^ "loaded_library" (** Relations present in every multigroup's catalog. *) let catalog_relation_names = @@ -29,6 +31,8 @@ let catalog_relation_names = on_rel_name; timing_rel_name; schema_rel_name; + function_predicate_rel_name; + loaded_library_rel_name; ] (** Relations exclusive to the sakura meta-multigroup. *) @@ -56,6 +60,16 @@ let timing_schema : Schema.t = Schema.empty |> Schema.add "timing" "string" let multigroup_schema : Schema.t = Schema.empty |> Schema.add "name" "string" let schema_schema : Schema.t = Schema.empty |> Schema.add "name" "string" +let function_predicate_schema : Schema.t = + Schema.empty + |> Schema.add "name" "string" + |> Schema.add "symbol" "string" + |> Schema.add "cardinality" "string" + |> Schema.add "purity" "string" + +let loaded_library_schema : Schema.t = + Schema.empty |> Schema.add "path" "string" + (** Definitions seeded into every multigroup. *) let catalog_definitions = [ @@ -66,6 +80,8 @@ let catalog_definitions = (on_rel_name, on_schema); (timing_rel_name, timing_schema); (schema_rel_name, schema_schema); + (function_predicate_rel_name, function_predicate_schema); + (loaded_library_rel_name, loaded_library_schema); ] (** Extra definitions seeded only into the sakura meta-multigroup. *) @@ -149,3 +165,43 @@ let build_schema_tuple schema_name : Tuple.materialized = { Attribute.value = Obj.magic schema_name }; } +let purity_to_string p = + Sexplib.Sexp.to_string (Conventions.Purity.sexp_of_t p) + +let purity_of_string s = + match Conventions.Purity.t_of_sexp (Sexplib.Sexp.of_string s) with + | p -> Some p + | exception _ -> None + +let cardinality_to_string c = + Sexplib.Sexp.to_string (Conventions.Cardinality.sexp_of_t c) + +let cardinality_of_string s = + match Conventions.Cardinality.t_of_sexp (Sexplib.Sexp.of_string s) with + | c -> Some c + | exception _ -> None + +let build_function_predicate_tuple ~name ~symbol ~cardinality ~purity : + Tuple.materialized = + { + Tuple.relation = function_predicate_rel_name; + attributes = + Tuple.AttributeMap.of_list + [ + ("name", { Attribute.value = Obj.magic name }); + ("symbol", { Attribute.value = Obj.magic symbol }); + ("cardinality", + { Attribute.value = Obj.magic (cardinality_to_string cardinality) }); + ("purity", + { Attribute.value = Obj.magic (purity_to_string purity) }); + ]; + } + +let build_loaded_library_tuple path : Tuple.materialized = + { + Tuple.relation = loaded_library_rel_name; + attributes = + Tuple.AttributeMap.singleton "path" + { Attribute.value = Obj.magic path }; + } + diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml index 2a507e5..b4f5834 100644 --- a/lib/prelude/standard.ml +++ b/lib/prelude/standard.ml @@ -31,6 +31,7 @@ let make_comparison ~name ~domain_name ~pred ~cardinality ~generator = ~cardinality ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base name) ~lineage:(Relation.Lineage.Base name) + () (** Enumerate pairs (a, b) where a < b using triangular indexing. *) let pair_of_nat_lt n = @@ -197,6 +198,7 @@ let plus_natural : Relation.t = ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "plus") ~lineage:(Relation.Lineage.Base "plus") + () let times_natural : Relation.t = let schema = @@ -236,6 +238,7 @@ let times_natural : Relation.t = ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "times") ~lineage:(Relation.Lineage.Base "times") + () let minus_natural : Relation.t = let schema = @@ -277,6 +280,7 @@ let minus_natural : Relation.t = ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "minus") ~lineage:(Relation.Lineage.Base "minus") + () let divide_natural : Relation.t = let schema = @@ -328,6 +332,7 @@ let divide_natural : Relation.t = ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "divide") ~lineage:(Relation.Lineage.Base "divide") + () let prelude_relations = [ less_than_natural diff --git a/lib/prl/ast.ml b/lib/prl/ast.ml new file mode 100644 index 0000000..1969da6 --- /dev/null +++ b/lib/prl/ast.ml @@ -0,0 +1,16 @@ +open Sexplib.Std + +type function_predicate = { + name : string; + schema : (string * string) list; + symbol : string; + purity : Conventions.Purity.t; + cardinality : Conventions.Cardinality.t; +} +[@@deriving sexp] + +type statement = + | LoadLibrary of string + | DefineFunctionPredicate of function_predicate + | ListFunctionPredicates +[@@deriving sexp] diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml new file mode 100644 index 0000000..d4ceca5 --- /dev/null +++ b/lib/prl/executor.ml @@ -0,0 +1,83 @@ +module Make (Storage : Management.Physical.S) = struct + module Ops = Manipulation.Make (Storage) + + type error = + | ParseError of string + | RuntimeError of string + | RelationError of Error.t + | UnknownPluginSymbol of string + | RelationNotFound of string + + let sexp_of_error e = + let open Sexplib.Sexp in + match e with + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | RuntimeError s -> List [ Atom "runtime-error"; Atom s ] + | RelationError err -> Error.sexp_of_error err + | UnknownPluginSymbol s -> List [ Atom "unknown-plugin-symbol"; Atom s ] + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + + let ( let* ) = Result.bind + let map_rel_error r = Result.map_error (fun e -> RelationError e) r + + let require_relation (db : Management.Database.t) rel_name = + match Management.Database.get_relation db rel_name with + | Some rel -> Ok rel + | None -> Error (RelationNotFound rel_name) + + let execute_load_library storage db path = + match Runtime.load_library path with + | Error e -> Error (RuntimeError e) + | Ok () -> + let* ll_rel = require_relation db Prelude.Catalog.loaded_library_rel_name in + let tuple = Prelude.Catalog.build_loaded_library_tuple path in + (match Ops.create_tuple storage db ll_rel tuple with + | Ok (new_db, _, _) -> Ok (Sublanguage_types.Transition new_db) + | Error (Error.DuplicateTuple _) -> Ok (Sublanguage_types.Transition db) + | Error e -> Error (RelationError e)) + + let execute_define_function_predicate storage db (spec : Ast.function_predicate) = + match Sakura_prl_api.find spec.symbol with + | None -> Error (UnknownPluginSymbol spec.symbol) + | Some impl -> + let schema = + List.fold_left + (fun s (a, d) -> Schema.add a d s) + Schema.empty spec.schema + in + let name = Qualified_name.(parse spec.name |> to_key) in + let generator = Runtime.make_generator name schema impl [] in + let producer = Runtime.make_producer name schema impl in + let membership_criteria = Runtime.make_membership_criteria schema impl in + let* new_db, _ = + Ops.create_immutable_relation storage db ~name ~schema ~generator + ~membership_criteria ~cardinality:spec.cardinality + ~producer:(Some producer) + |> map_rel_error + in + let* fp_rel = + require_relation new_db Prelude.Catalog.function_predicate_rel_name + in + let fp_tuple = + Prelude.Catalog.build_function_predicate_tuple ~name + ~symbol:spec.symbol ~cardinality:spec.cardinality ~purity:spec.purity + in + let* final_db = + Ops.create_tuple storage new_db fp_rel fp_tuple + |> map_rel_error + |> Result.map (fun (db, _, _) -> db) + in + Ok (Sublanguage_types.Transition final_db) + + let execute_list_function_predicates db = + require_relation db Prelude.Catalog.function_predicate_rel_name + |> Result.map (fun rel -> Sublanguage_types.Query rel) + + let execute storage db = function + | Ast.LoadLibrary path -> execute_load_library storage db path + | Ast.DefineFunctionPredicate spec -> + execute_define_function_predicate storage db spec + | Ast.ListFunctionPredicates -> execute_list_function_predicates db +end + +module Memory = Make (Management.Physical.Memory) diff --git a/lib/prl/parser.ml b/lib/prl/parser.ml new file mode 100644 index 0000000..17102a4 --- /dev/null +++ b/lib/prl/parser.ml @@ -0,0 +1,12 @@ +type error = ParseError of string + +let of_sexp sexp = + let sexp = + match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other + in + match Ast.statement_of_sexp sexp with + | stmt -> Ok stmt + | exception exn -> Error (ParseError (Printexc.to_string exn)) + +let of_string s = of_sexp (Sexplib.Sexp.of_string s) +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/prl/runtime.ml b/lib/prl/runtime.ml new file mode 100644 index 0000000..d5e28ec --- /dev/null +++ b/lib/prl/runtime.ml @@ -0,0 +1,84 @@ +type t = { + loaded_libraries : (string, unit) Hashtbl.t; + mutex : Mutex.t; +} + +let state : t = + { loaded_libraries = Hashtbl.create 16; mutex = Mutex.create () } + +let load_library path : (unit, string) result = + Mutex.protect state.mutex (fun () -> + if Hashtbl.mem state.loaded_libraries path then Ok () + else + try + Dynlink.loadfile path; + Hashtbl.replace state.loaded_libraries path (); + Ok () + with Dynlink.Error e -> Error (Dynlink.error_message e)) + +(* Convert an engine materialized tuple to the plugin's (string * Obj.t) list format. *) +let to_plugin_row (schema : Schema.t) (tuple : Tuple.materialized) : + Sakura_prl_api.tuple option = + let rec go acc = function + | [] -> Some (List.rev acc) + | (attr_name, _) :: rest -> ( + match Tuple.AttributeMap.find_opt attr_name tuple.attributes with + | None -> None + | Some attr -> go ((attr_name, attr.Attribute.value) :: acc) rest) + in + go [] schema + +(* Convert a plugin row back to an engine materialized tuple. *) +let of_plugin_row relation_name (schema : Schema.t) + (row : Sakura_prl_api.tuple) : Tuple.materialized option = + let rec go acc = function + | [] -> Some { Tuple.relation = relation_name; attributes = acc } + | (attr_name, _) :: rest -> ( + match List.assoc_opt attr_name row with + | None -> None + | Some value -> + go (Tuple.AttributeMap.add attr_name { Attribute.value = value } acc) + rest) + in + go Tuple.AttributeMap.empty schema + +(* Wrap a list of plugin rows as a generator. Uses an array for O(1) indexing. *) +let rows_to_generator relation_name schema (rows : Sakura_prl_api.tuple list) : + Generator.t = + let arr = Array.of_list rows in + let n = Array.length arr in + let rec gen i _pos = + if i >= n then Generator.Done + else + match of_plugin_row relation_name schema arr.(i) with + | None -> Generator.Error "Plugin row does not conform to predicate schema." + | Some tuple -> Generator.Value (Tuple.Materialized tuple, gen (i + 1)) + in + gen 0 + +let make_generator relation_name schema (impl : Sakura_prl_api.implementation) + (bindings : Sakura_prl_api.tuple) : Generator.t = + match impl.produce with + | None -> fun _ -> Generator.Done + | Some produce -> + let rows_result = lazy (produce bindings) in + fun _pos -> + match Lazy.force rows_result with + | Error e -> Generator.Error e + | Ok rows -> rows_to_generator relation_name schema rows _pos + +let make_producer relation_name schema (impl : Sakura_prl_api.implementation) : + Relation.producer = + fun bindings -> make_generator relation_name schema impl bindings + +let make_membership_criteria schema (impl : Sakura_prl_api.implementation) : + (string -> Merkle.t option) -> Tuple.t -> bool = + match impl.membership_criteria with + | None -> fun _ _ -> false + | Some check -> + fun _tree_of -> function + | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> ( + match to_plugin_row schema m with + | None -> false + | Some row -> (match check row with Ok b -> b | Error _ -> false)) diff --git a/lib/prl/sublanguage.ml b/lib/prl/sublanguage.ml new file mode 100644 index 0000000..b23f370 --- /dev/null +++ b/lib/prl/sublanguage.ml @@ -0,0 +1,21 @@ +module Make (Storage : Management.Physical.S) = struct + module Exec = Executor.Make (Storage) + + type configuration = unit + type storage = Storage.t + type ast = Ast.statement + type error = Exec.error + + let name = "prl" + let parse _ = Ok () + + let parse_sexp sexp = + match Parser.of_sexp sexp with + | Ok r -> Ok r + | Error (Parser.ParseError s) -> Error (Exec.ParseError s) + + let execute = Exec.execute + let sexp_of_error = Exec.sexp_of_error +end + +module Memory = Make (Management.Physical.Memory) diff --git a/lib/relation.ml b/lib/relation.ml index 0855b57..6e6a23c 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -28,6 +28,8 @@ module Lineage = struct | Aggregate of string * string * t end +type producer = (string * Conventions.AbstractValue.t) list -> Generator.t + type t = { hash : Conventions.Hash.t option; name : Conventions.Name.t; @@ -36,13 +38,13 @@ type t = { constraints : RelationConstraint.t option; cardinality : Conventions.Cardinality.t; generator : Generator.t option; + producer : producer option; membership_criteria : (string -> Tree.t option) -> Tuple.t -> bool; provenance : Provenance.t; lineage : Lineage.t; } -let make ~hash ~name ~schema ~tree ~constraints ~cardinality ~generator - ~membership_criteria ~provenance ~lineage = +let make ?(producer = None) ~hash ~name ~schema ~tree ~constraints ~cardinality ~generator ~membership_criteria ~provenance ~lineage () = { hash; name; @@ -51,6 +53,7 @@ let make ~hash ~name ~schema ~tree ~constraints ~cardinality ~generator constraints; cardinality; generator; + producer; membership_criteria; provenance; lineage; diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index c931b0c..722ba08 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -19,7 +19,7 @@ module Make (Storage : Management.Physical.S) = struct |> Result.map (function | Executor.Batch { cursor_id; rows; has_more } -> Sublanguage_types.Cursor { cursor_id; rows; has_more } - | Executor.Closed db -> Sublanguage_types.Transition (db, "cursor closed")) + | Executor.Closed db -> Sublanguage_types.Transition db) let sexp_of_error = Exec.sexp_of_error end diff --git a/lib/sublanguage_types.ml b/lib/sublanguage_types.ml index d82d6aa..14ee20f 100644 --- a/lib/sublanguage_types.ml +++ b/lib/sublanguage_types.ml @@ -6,7 +6,7 @@ type cursor_result = { type result = | Query of Relation.t - | Transition of Management.Database.t * string + | Transition of Management.Database.t | Cursor of cursor_result | SessionSwitch of string - | CreateMultigroup of string \ No newline at end of file + | CreateMultigroup of string diff --git a/prl_api/dune b/prl_api/dune new file mode 100644 index 0000000..815a625 --- /dev/null +++ b/prl_api/dune @@ -0,0 +1,3 @@ +(library + (name sakura_prl_api) + (public_name sakura.prl_api)) diff --git a/prl_api/sakura_prl_api.ml b/prl_api/sakura_prl_api.ml new file mode 100644 index 0000000..92fd658 --- /dev/null +++ b/prl_api/sakura_prl_api.ml @@ -0,0 +1,32 @@ +type value = Obj.t +type tuple = (string * value) list + +type implementation = { + membership_criteria : (tuple -> (bool, string) result) option; + produce : (tuple -> (tuple list, string) result) option; +} + +(* TODO: Rethink this instead in terms of a value. + We need to store the references as a normal relation + on the multigroup relation catalog. *) +let registry : (string, implementation) Hashtbl.t = Hashtbl.create 32 +let mutex = Mutex.create () + +let register symbol impl = + Mutex.protect mutex (fun () -> Hashtbl.replace registry symbol impl) + +let find symbol = Mutex.protect mutex (fun () -> Hashtbl.find_opt registry symbol) + +let symbols () = + Mutex.protect mutex (fun () -> Hashtbl.to_seq_keys registry |> List.of_seq) + +let implementation_of_rows ?membership_criteria (rows : tuple list) : implementation = + { membership_criteria; produce = Some (fun _bindings -> Ok rows) } + +let implementation_of_producer ?membership_criteria + (produce : tuple -> (tuple list, string) result) : implementation = + { membership_criteria; produce = Some produce } + +let implementation_of_unit_producer ?membership_criteria + (produce : unit -> (tuple list, string) result) : implementation = + { membership_criteria; produce = Some (fun _bindings -> produce ()) } diff --git a/run_tcp.ps1 b/run_tcp.ps1 new file mode 100644 index 0000000..175fc26 --- /dev/null +++ b/run_tcp.ps1 @@ -0,0 +1,175 @@ +param( + [string]$ConfigPath = ".\config.sexp", + [string]$ServerHost = "127.0.0.1", + [int]$Port = 7777, + [string[]]$Command, + [string]$CommandsPath, + [switch]$UseExistingServer, + [switch]$UseLocalServer, + [switch]$SkipBuild, + [switch]$NoInteractive +) + +$ErrorActionPreference = "Stop" + +function Invoke-Build { + Write-Host "Building Sakura..." + dune build + if (-not $?) { + throw "Build failed." + } +} + +function Start-SakuraServer { + param( + [string]$Config, + [string]$WorkingDirectory, + [switch]$UseOpam + ) + + Write-Host "Starting Sakura server with config $Config ..." + $filePath = "dune" + $serverArgs = @("exec", "sakura-server", "--", $Config) + if ($UseOpam) { + $filePath = "opam" + $serverArgs = @("exec", "--", "sakura-server", $Config) + } + + $proc = Start-Process -FilePath $filePath ` + -ArgumentList $serverArgs ` + -WorkingDirectory $WorkingDirectory ` + -PassThru + + return $proc +} + +function Wait-ForTcp { + param( + [string]$TargetHost, + [int]$TargetPort, + [int]$TimeoutSeconds = 20 + ) + + $deadline = (Get-Date).AddSeconds($TimeoutSeconds) + while ((Get-Date) -lt $deadline) { + $client = $null + try { + $client = [System.Net.Sockets.TcpClient]::new() + $async = $client.BeginConnect($TargetHost, $TargetPort, $null, $null) + if ($async.AsyncWaitHandle.WaitOne(250)) { + $client.EndConnect($async) + $client.Close() + return + } + $client.Close() + } catch { + if ($null -ne $client) { + $client.Close() + } + Start-Sleep -Milliseconds 250 + } + } + + throw "Timed out waiting for TCP server at $TargetHost`:$TargetPort" +} + +function Connect-Tcp { + param( + [string]$TargetHost, + [int]$TargetPort + ) + + $client = [System.Net.Sockets.TcpClient]::new($TargetHost, $TargetPort) + $stream = $client.GetStream() + $writer = [System.IO.StreamWriter]::new($stream) + $writer.AutoFlush = $true + $reader = [System.IO.StreamReader]::new($stream) + + return @{ + Client = $client + Writer = $writer + Reader = $reader + } +} + +function Send-Command { + param( + [System.IO.StreamWriter]$Writer, + [System.IO.StreamReader]$Reader, + [string]$Line + ) + + $Writer.WriteLine($Line) + $response = $Reader.ReadLine() + if ($null -eq $response) { + throw "Connection closed by server." + } + + Write-Host "< $response" +} + +$repoRoot = $PSScriptRoot +$serverProcess = $null + +try { + if (-not $SkipBuild) { + Invoke-Build + } + + if (-not $UseExistingServer) { + if ($UseLocalServer) { + Write-Host "Server mode: local dune exec sakura-server" + } else { + Write-Host "Server mode: opam-installed sakura-server" + } + $serverProcess = Start-SakuraServer -Config $ConfigPath -WorkingDirectory $repoRoot -UseOpam:(-not $UseLocalServer) + Wait-ForTcp -TargetHost $ServerHost -TargetPort $Port + Write-Host "Server is ready on $ServerHost`:$Port" + } + + $conn = Connect-Tcp -TargetHost $ServerHost -TargetPort $Port + $writer = $conn.Writer + $reader = $conn.Reader + + $commandsToSend = @() + if ($null -ne $Command -and $Command.Count -gt 0) { + $commandsToSend += $Command + } + if (-not [string]::IsNullOrWhiteSpace($CommandsPath)) { + $fileCommands = Get-Content -Path $CommandsPath | + Where-Object { -not [string]::IsNullOrWhiteSpace($_) } + $commandsToSend += $fileCommands + } + + if ($commandsToSend.Count -gt 0) { + foreach ($cmd in $commandsToSend) { + Write-Host "> $cmd" + Send-Command -Writer $writer -Reader $reader -Line $cmd + } + } + + if (-not $NoInteractive) { + Write-Host "Interactive mode. Type :quit to exit." + while ($true) { + $line = Read-Host ">" + if ($line -eq ":quit") { + break + } + if ([string]::IsNullOrWhiteSpace($line)) { + continue + } + + Send-Command -Writer $writer -Reader $reader -Line $line + } + } + + $writer.Dispose() + $reader.Dispose() + $conn.Client.Close() +} +finally { + if ($null -ne $serverProcess -and -not $serverProcess.HasExited) { + Write-Host "Stopping Sakura server (PID $($serverProcess.Id))" + Stop-Process -Id $serverProcess.Id -Force + } +} diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml index 7d45725..12fac52 100644 --- a/test/test_relational_engine.ml +++ b/test/test_relational_engine.ml @@ -150,6 +150,7 @@ let%test_unit "database: add relation" = ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "users") + () in let db = Management.Database.add_relation db ~relation in assert (Management.Database.has_relation db "users"); @@ -165,6 +166,7 @@ let%test_unit "database: remove relation" = ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "users") + () in let db = Management.Database.add_relation db ~relation in assert (Management.Database.has_relation db "users"); @@ -180,6 +182,7 @@ let%test_unit "database: update relation" = ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "users") + () in let db = Management.Database.add_relation db ~relation in let old_db_hash = db.hash in @@ -198,6 +201,7 @@ let%test_unit "database: get relation names" = ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "users") + () in let rel2 = Relation.make ~hash:(Some "h2") ~name:"orders" ~schema:Schema.empty @@ -206,6 +210,7 @@ let%test_unit "database: get relation names" = ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "orders") + () in let db = Management.Database.add_relation db ~relation:rel1 in let db = Management.Database.add_relation db ~relation:rel2 in @@ -2341,6 +2346,7 @@ let%test_unit "constraint scenario: self-reference neq" = | _ -> false) | _ -> false) ~cardinality:Conventions.Cardinality.AlephZero + ~producer:None with | Error _ -> assert false | Ok x -> x @@ -2730,6 +2736,70 @@ let%test_unit "ddl: round-trip RegisterDomain" = | Error _ -> assert false | Ok parsed -> assert (parsed = src) +let%test_unit "prl: round-trip DefineFunctionPredicate" = + let src = + Prl.Ast.DefineFunctionPredicate + { + name = "numbers:ones"; + schema = [ ("x", "natural") ]; + symbol = "test.ones"; + purity = Conventions.Purity.Pure; + cardinality = Conventions.Cardinality.ConstrainedFinite; + } + in + match Prl.Parser.of_string (Prl.Parser.to_string src) with + | Error _ -> assert false + | Ok parsed -> assert (parsed = src) + +let%test_unit "prl: define predicate and query via DRL" = + with_storage (fun storage -> + let db = + match Memory.create_database storage ~name:"prl_db" with + | Error _ -> assert false + | Ok db -> db + in + Sakura_prl_api.register "test.ones" + (Sakura_prl_api.implementation_of_rows + ~membership_criteria:(fun tuple -> + match List.assoc_opt "x" tuple with + | Some v -> Ok ((Obj.obj v : int) = 1) + | None -> Ok false) + [ [ ("x", Obj.repr 1) ] ]); + let stmt = + Prl.Ast.DefineFunctionPredicate + { + name = "ones"; + schema = [ ("x", "natural") ]; + symbol = "test.ones"; + purity = Conventions.Purity.Pure; + cardinality = Conventions.Cardinality.ConstrainedFinite; + } + in + let db = + match Prl.Executor.Memory.execute storage db stmt with + | Error _ -> assert false + | Ok (Sublanguage_types.Transition new_db) -> new_db + | Ok _ -> assert false + in + let rel = + match Drl.Executor.Memory.execute storage db (Drl.Ast.Base "ones") with + | Error _ -> assert false + | Ok rel -> rel + in + let tuples = + match Algebra.Memory.materialize storage rel with + | Error _ -> assert false + | Ok tuples -> tuples + in + assert (List.length tuples = 1); + match tuples with + | [ tuple ] -> ( + match Tuple.AttributeMap.find_opt "x" tuple.Tuple.attributes with + | None -> assert false + | Some attr -> assert ((Obj.obj attr.Attribute.value : int) = 1)) + | _ -> assert false) + + (* Executor tests construct AST directly, no dependency on sexp format *) let%test_unit "ddl: execute CreateDatabase" = -- cgit v1.2.3