diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/algebra.ml | 204 | ||||
| -rw-r--r-- | lib/catalog.ml | 34 | ||||
| -rw-r--r-- | lib/conventions.ml | 12 | ||||
| -rw-r--r-- | lib/dcl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/ddl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/dml/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/drl/executor.ml | 39 | ||||
| -rw-r--r-- | lib/dune | 2 | ||||
| -rw-r--r-- | lib/icl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/listener.ml | 6 | ||||
| -rw-r--r-- | lib/management/branch.ml | 2 | ||||
| -rw-r--r-- | lib/manipulation.ml | 9 | ||||
| -rw-r--r-- | lib/prelude/catalog.ml | 56 | ||||
| -rw-r--r-- | lib/prelude/standard.ml | 5 | ||||
| -rw-r--r-- | lib/prl/ast.ml | 16 | ||||
| -rw-r--r-- | lib/prl/executor.ml | 83 | ||||
| -rw-r--r-- | lib/prl/parser.ml | 12 | ||||
| -rw-r--r-- | lib/prl/runtime.ml | 84 | ||||
| -rw-r--r-- | lib/prl/sublanguage.ml | 21 | ||||
| -rw-r--r-- | lib/relation.ml | 7 | ||||
| -rw-r--r-- | lib/scl/sublanguage.ml | 2 | ||||
| -rw-r--r-- | lib/sublanguage_types.ml | 4 |
22 files changed, 502 insertions, 104 deletions
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) @@ -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 |