diff options
Diffstat (limited to '')
| -rw-r--r-- | bin/server.ml | 2 | ||||
| -rw-r--r-- | lib/algebra.ml | 29 | ||||
| -rw-r--r-- | lib/catalog.ml | 110 | ||||
| -rw-r--r-- | lib/configuration.ml | 6 | ||||
| -rw-r--r-- | lib/conventions.ml | 3 | ||||
| -rw-r--r-- | lib/dcl/sublanguage.ml | 6 | ||||
| -rw-r--r-- | lib/ddl/executor.ml | 4 | ||||
| -rw-r--r-- | lib/dml/executor.ml | 16 | ||||
| -rw-r--r-- | lib/drl/executor.ml | 24 | ||||
| -rw-r--r-- | lib/envelope.ml | 9 | ||||
| -rw-r--r-- | lib/error.ml | 38 | ||||
| -rw-r--r-- | lib/icl/executor.ml | 4 | ||||
| -rw-r--r-- | lib/listener.ml | 5 | ||||
| -rw-r--r-- | lib/management/branch.ml | 6 | ||||
| -rw-r--r-- | lib/management/merge.ml | 7 | ||||
| -rw-r--r-- | lib/manipulation.ml | 20 | ||||
| -rw-r--r-- | lib/prelude/catalog.ml | 18 | ||||
| -rw-r--r-- | lib/prelude/standard.ml | 159 | ||||
| -rw-r--r-- | lib/prl/executor.ml | 18 | ||||
| -rw-r--r-- | lib/prl/runtime.ml | 25 | ||||
| -rw-r--r-- | lib/qualified_name.ml | 6 | ||||
| -rw-r--r-- | lib/qualified_name.mli | 16 | ||||
| -rw-r--r-- | lib/relation.ml | 3 | ||||
| -rw-r--r-- | lib/session.ml | 6 | ||||
| -rw-r--r-- | lib/system.ml | 29 | ||||
| -rw-r--r-- | lib/transport.ml | 34 | ||||
| -rw-r--r-- | lib/utilities.ml | 4 | ||||
| -rw-r--r-- | prl_api/sakura_prl_api.ml | 6 | ||||
| -rw-r--r-- | test/test_relational_engine.ml | 387 |
29 files changed, 421 insertions, 579 deletions
diff --git a/bin/server.ml b/bin/server.ml index 2423c37..c2a4957 100644 --- a/bin/server.ml +++ b/bin/server.ml @@ -3,7 +3,7 @@ open Relational_engine let () = if Array.length Sys.argv <> 2 then begin Printf.eprintf "Usage: %s <config-file>\n%!" Sys.argv.(0); - exit 1; + exit 1 end; match System.run_from_config Sys.argv.(1) with | Error e -> diff --git a/lib/algebra.ml b/lib/algebra.ml index d1eb26f..41b2256 100644 --- a/lib/algebra.ml +++ b/lib/algebra.ml @@ -46,8 +46,7 @@ module Make (Storage : Management.Physical.S) = struct ~generator:(Some gen) ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "derived") - () + ~lineage:(Relation.Lineage.Base "derived") () let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : Relation.t = @@ -224,8 +223,7 @@ module Make (Storage : Management.Physical.S) = struct let matches = List.filter_map (fun rt -> - if get_vals attrs rt = lv then Some (merge lt rt) - else None) + if get_vals attrs rt = lv then Some (merge lt rt) else None) right_tuples in match matches with @@ -254,15 +252,15 @@ module Make (Storage : Management.Physical.S) = struct let left_gen = to_generator storage left 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) -> + | Generator.Value (lt, next_left) -> ( let bindings = bindings_of_tuple attrs lt in - (match drain (right_producer bindings) with + match drain (right_producer bindings) with | Error (GeneratorError e | StorageError e) -> Generator.Error e - | Ok right_tuples -> + | Ok right_tuples -> ( let lv = get_vals attrs lt in let matches = List.filter_map @@ -271,7 +269,7 @@ module Make (Storage : Management.Physical.S) = struct else None) right_tuples in - (match matches with + match matches with | [] -> from_left next_left (lpos + 1) _pos | _ -> chain_with_cont (list_generator matches) @@ -284,9 +282,9 @@ module Make (Storage : Management.Physical.S) = struct (of_generator ~name ~schema:merged_schema ?constraints:merged_constraints (make_right_producer_join_gen left_gen)) - | _ -> + | _ -> ( let right_gen = to_generator storage right in - (match drain right_gen with + match drain right_gen with | Error e -> Error e | Ok right_tuples -> let left_gen_result = @@ -297,9 +295,9 @@ module Make (Storage : Management.Physical.S) = struct 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) + 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 @@ -308,8 +306,7 @@ module Make (Storage : Management.Physical.S) = struct match drain (left_producer bindings) with | Ok new_ts -> Ok (ts @ new_ts) | Error e -> Error e)) - (Ok []) - unique_bindings + (Ok []) unique_bindings |> Result.map list_generator | _ -> Ok (to_generator storage left) in diff --git a/lib/catalog.ml b/lib/catalog.ml index 74fe3de..605c40a 100644 --- a/lib/catalog.ml +++ b/lib/catalog.ml @@ -1,9 +1,9 @@ (** Multi-multigroup catalog. Each multigroup gets its own [Atomic.t], so mutations to independent - multigroups never contend. The [sakura] multigroup is auto-bootstrapped, - undeletable, and self-referential: it carries a [public:multigroup] - relation listing every registered multigroup. *) + multigroups never contend. The [sakura] multigroup is auto-bootstrapped, + undeletable, and self-referential: it carries a [public:multigroup] relation + listing every registered multigroup. *) type t = { multigroups : Management.Database.t Atomic.t Utilities.StringMap.t Atomic.t; @@ -19,8 +19,8 @@ module Make (S : Management.Physical.S with type error = string) = struct type nonrec t = t - let map_error r = Result.map_error - (fun e -> Sexplib.Sexp.to_string (Error.sexp_of_error e)) r + let map_error r = + Result.map_error (fun e -> Sexplib.Sexp.to_string (Error.sexp_of_error e)) r let get catalog name = Utilities.StringMap.find_opt name (Atomic.get catalog.multigroups) @@ -42,14 +42,15 @@ module Make (S : Management.Physical.S with type error = string) = struct 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 + Management.Database.get_relation db + Prelude.Catalog.loaded_library_rel_name with | None -> () - | Some rel -> + | Some rel -> ( let hashes = match rel.Relation.tree with None -> [] | Some t -> Merkle.keys t in - (match Manip.load_tuples storage hashes with + match Manip.load_tuples storage hashes with | Error _ -> () | Ok tuples -> List.iter @@ -69,19 +70,21 @@ module Make (S : Management.Physical.S with type error = string) = struct with | Ok (new_db, _) -> new_db | Error e -> - Printf.eprintf "Warning: prelude relation %s: %s\n%!" - rel.name (Sexplib.Sexp.to_string (Error.sexp_of_error e)); + Printf.eprintf "Warning: prelude relation %s: %s\n%!" rel.name + (Sexplib.Sexp.to_string (Error.sexp_of_error e)); db (** 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 - let db = List.fold_left (register_prelude_relation storage) db prelude_relations in + 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. *) + (** Create additional catalog relations beyond the base six. Used to seed + [public:multigroup] into the sakura multigroup only. *) let seed_extra_catalog storage ~definitions db = List.fold_left (fun acc (name, schema) -> @@ -92,13 +95,14 @@ module Make (S : Management.Physical.S with type error = string) = struct Ok new_db) (Ok db) definitions - (** Write a tuple into sakura's [public:multigroup] and update the ref. - No-op if the relation doesn't exist yet (bootstrap ordering). *) + (** Write a tuple into sakura's [public:multigroup] and update the ref. No-op + if the relation doesn't exist yet (bootstrap ordering). *) let register_in_sakura storage sakura_ref mg_name = let rec go () = let sakura = Atomic.get sakura_ref in match - Management.Database.get_relation sakura Prelude.Catalog.multigroup_rel_name + Management.Database.get_relation sakura + Prelude.Catalog.multigroup_rel_name with | None -> Ok () | Some mg_rel -> @@ -122,29 +126,39 @@ module Make (S : Management.Physical.S with type error = string) = struct let sakura_ref = Atomic.make sakura_db in let* () = register_in_sakura storage sakura_ref sakura_name in let map = Utilities.StringMap.singleton sakura_name sakura_ref in - Ok { multigroups = Atomic.make map; default_multigroup = sakura_name; mutex = Mutex.create () } + Ok + { + multigroups = Atomic.make map; + default_multigroup = sakura_name; + mutex = Mutex.create (); + } let add catalog storage ~prelude_relations name = Mutex.protect catalog.mutex (fun () -> - let map = Atomic.get catalog.multigroups in - if Utilities.StringMap.mem name map then - Error (Printf.sprintf "Multigroup %s already exists" name) - else - let* db = bootstrap_multigroup storage ~prelude_relations ~name in - let db_ref = Atomic.make db in - let* () = - match Utilities.StringMap.find_opt sakura_name map with - | Some sakura_ref -> register_in_sakura storage sakura_ref name - | None -> Ok () - in - let new_map = Utilities.StringMap.add name db_ref map in - let* () = publish_multigroups catalog ~expected:map ~updated:new_map in - Ok db_ref) + let map = Atomic.get catalog.multigroups in + if Utilities.StringMap.mem name map then + Error (Printf.sprintf "Multigroup %s already exists" name) + else + let* db = bootstrap_multigroup storage ~prelude_relations ~name in + let db_ref = Atomic.make db in + let* () = + match Utilities.StringMap.find_opt sakura_name map with + | Some sakura_ref -> register_in_sakura storage sakura_ref name + | None -> Ok () + in + let new_map = Utilities.StringMap.add name db_ref map in + let* () = + publish_multigroups catalog ~expected:map ~updated:new_map + in + Ok db_ref) let unregister_from_sakura storage sakura_ref mg_name = let rec go () = let sakura = Atomic.get sakura_ref in - match Management.Database.get_relation sakura Prelude.Catalog.multigroup_rel_name with + match + Management.Database.get_relation sakura + Prelude.Catalog.multigroup_rel_name + with | None -> Ok () | Some mg_rel -> let tuple_hash = @@ -159,22 +173,22 @@ module Make (S : Management.Physical.S with type error = string) = struct go () let remove catalog storage name = - if name = sakura_name then - Error "Cannot remove the sakura system catalog" + if name = sakura_name then Error "Cannot remove the sakura system catalog" else Mutex.protect catalog.mutex (fun () -> - let map = Atomic.get catalog.multigroups in - if not (Utilities.StringMap.mem name map) then - Error (Printf.sprintf "Multigroup %s does not exist" name) - else - let* () = - match Utilities.StringMap.find_opt sakura_name map with - | None -> Ok () - | Some sakura_ref -> unregister_from_sakura storage sakura_ref name - in - let new_map = Utilities.StringMap.remove name map in - let* () = - publish_multigroups catalog ~expected:map ~updated:new_map - in - Ok ()) + let map = Atomic.get catalog.multigroups in + if not (Utilities.StringMap.mem name map) then + Error (Printf.sprintf "Multigroup %s does not exist" name) + else + let* () = + match Utilities.StringMap.find_opt sakura_name map with + | None -> Ok () + | Some sakura_ref -> + unregister_from_sakura storage sakura_ref name + in + let new_map = Utilities.StringMap.remove name map in + let* () = + publish_multigroups catalog ~expected:map ~updated:new_map + in + Ok ()) end diff --git a/lib/configuration.ml b/lib/configuration.ml index 6229ce6..3f66ac0 100644 --- a/lib/configuration.ml +++ b/lib/configuration.ml @@ -26,9 +26,11 @@ let insert_section ~expected acc key body = in match body with | [ subtree ] -> Ok (Utilities.StringMap.add key subtree acc) - | [] -> errorf "Configuration section %s is empty (expected a tagged value)" key + | [] -> + errorf "Configuration section %s is empty (expected a tagged value)" key | _ -> - errorf "Configuration section %s has multiple values (expected exactly one)" + errorf + "Configuration section %s has multiple values (expected exactly one)" key (** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *) diff --git a/lib/conventions.ml b/lib/conventions.ml index cdc63a9..fe85737 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -20,8 +20,7 @@ module Cardinality = struct end module Purity = struct - type t = Pure | IO - [@@deriving sexp] + type t = Pure | IO [@@deriving sexp] end module AbstractValue = struct diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml index ecd2e60..34d4c62 100644 --- a/lib/dcl/sublanguage.ml +++ b/lib/dcl/sublanguage.ml @@ -17,8 +17,10 @@ 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, _)) -> Ok (Sublanguage_types.Transition db) - | Ok (Exec.Switch multigroup) -> Ok (Sublanguage_types.SessionSwitch multigroup) - | Ok (Exec.NewMultigroup name) -> Ok (Sublanguage_types.CreateMultigroup name) + | Ok (Exec.Switch multigroup) -> + Ok (Sublanguage_types.SessionSwitch multigroup) + | Ok (Exec.NewMultigroup name) -> + Ok (Sublanguage_types.CreateMultigroup name) | Error e -> Error e let sexp_of_error = Exec.sexp_of_error diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml index 9df878d..2a0c205 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -9,9 +9,9 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] | ManipulationError e -> Error.sexp_of_error e - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] let ( let* ) = Result.bind let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml index e92b0f5..a4b4e21 100644 --- a/lib/dml/executor.ml +++ b/lib/dml/executor.ml @@ -12,11 +12,13 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | ManipulationError e -> Error.sexp_of_error e - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] - | AlgebraError (Algebra.StorageError s) -> List [Atom "storage-error"; Atom s] - | AlgebraError (Algebra.GeneratorError s) -> List [Atom "generator-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | ManipulationError e -> Error.sexp_of_error e + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + | AlgebraError (Algebra.StorageError s) -> + List [ Atom "storage-error"; Atom s ] + | AlgebraError (Algebra.GeneratorError s) -> + List [ Atom "generator-error"; Atom s ] let ( let* ) = Result.bind let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r @@ -122,7 +124,9 @@ module Make (Storage : Management.Physical.S) = struct (fun acc t -> let* db = acc in let* rel = get_rel db target in - let tuple_hash = Hashing.hash_tuple (retarget rel.Relation.name t) in + let tuple_hash = + Hashing.hash_tuple (retarget rel.Relation.name t) + in let* db, _ = Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip in diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index 3ff4553..1172553 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -24,14 +24,15 @@ module Make (Storage : Management.Physical.S) = struct let common = List.filter_map (fun (n, _) -> - if List.exists (fun (m, _) -> m = n) filter.Relation.schema - then Some 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)) + 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 = @@ -54,26 +55,21 @@ module Make (Storage : Management.Physical.S) = struct 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 -> - wrap (Alg.equijoin storage [] r1 r2) + execute storage db q2 >>= fun r2 -> 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/envelope.ml b/lib/envelope.ml index 4b8bc46..1c20c5b 100644 --- a/lib/envelope.ml +++ b/lib/envelope.ml @@ -9,9 +9,8 @@ type tagged = { tag : string; payload : Sexplib.Sexp.t } let parse (input : Sexplib.Sexp.t) : (tagged, Error.t) Result.t = match input with | Sexplib.Sexp.List (Sexplib.Sexp.Atom tag :: rest) -> - let payload = match rest with - | [single] -> single - | many -> Sexplib.Sexp.List many - in - Ok { tag; payload } + let payload = + match rest with [ single ] -> single | many -> Sexplib.Sexp.List many + in + Ok { tag; payload } | s -> Error (Error.MalformedExpression s) diff --git a/lib/error.ml b/lib/error.ml index 09b2e53..cf02845 100644 --- a/lib/error.ml +++ b/lib/error.ml @@ -1,4 +1,3 @@ - (** Error types for manipulation operations *) type t = | RelationNotFound of string @@ -11,26 +10,33 @@ type t = | MalformedExpression of Sexplib.Sexp.t (* TODO: think of a better way to manage and serialize sublanguage errors *) | SublanguageError of Sexplib.Sexp.t - | Conflict of { old_db : Management.Database.t; new_db : Management.Database.t} + | Conflict of { + old_db : Management.Database.t; + new_db : Management.Database.t; + } | SyntaxError of string | MultigroupNotFound of string let sexp_of_error e = let open Sexplib.Sexp in let error e ps = List (Atom e :: ps) in - let (<+>) key value = List [Atom key; value] in + let ( <+> ) key value = List [ Atom key; value ] in match e with (* TODO: think of a subset of common attributes that every error should have (message, etc)? *) - | RelationNotFound s -> error "relation-not-found" ["relation" <+> (Atom s)] - | RelationAlreadyExists s -> error "relation-already-exists" ["relation" <+> (Atom s)] - | TupleNotFound h -> error "tuple-not-found" ["hash" <+> (Atom h)] - | DuplicateTuple h -> error "duplicate-tuple" ["hash" <+> (Atom h)] - | ConstraintViolation s -> error "constraint-violation" ["message" <+> (Atom s)] - | StorageError s -> error "storage-error" ["message" <+> (Atom s)] - | UnrecognizedSublanguage s -> error "unrecognized-sublanguage" ["tag" <+> (Atom s)] - | MalformedExpression s -> error "malformed-expression" ["expression" <+> s] - | SublanguageError s -> error "sublanguage-error" ["error" <+> s] - | SyntaxError s -> error "syntax-error" ["message" <+> (Atom s)] - | MultigroupNotFound s -> error "multigroup-not-found" ["name" <+> (Atom s)] - | Conflict { old_db; new_db } -> error "conflict" ["old-hash" <+> (Atom old_db.hash); - "new-hash" <+> (Atom new_db.hash)] + | RelationNotFound s -> error "relation-not-found" [ "relation" <+> Atom s ] + | RelationAlreadyExists s -> + error "relation-already-exists" [ "relation" <+> Atom s ] + | TupleNotFound h -> error "tuple-not-found" [ "hash" <+> Atom h ] + | DuplicateTuple h -> error "duplicate-tuple" [ "hash" <+> Atom h ] + | ConstraintViolation s -> + error "constraint-violation" [ "message" <+> Atom s ] + | StorageError s -> error "storage-error" [ "message" <+> Atom s ] + | UnrecognizedSublanguage s -> + error "unrecognized-sublanguage" [ "tag" <+> Atom s ] + | MalformedExpression s -> error "malformed-expression" [ "expression" <+> s ] + | SublanguageError s -> error "sublanguage-error" [ "error" <+> s ] + | SyntaxError s -> error "syntax-error" [ "message" <+> Atom s ] + | MultigroupNotFound s -> error "multigroup-not-found" [ "name" <+> Atom s ] + | Conflict { old_db; new_db } -> + error "conflict" + [ "old-hash" <+> Atom old_db.hash; "new-hash" <+> Atom new_db.hash ] diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml index 6238906..6f85b60 100644 --- a/lib/icl/executor.ml +++ b/lib/icl/executor.ml @@ -9,9 +9,9 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] | ManipulationError e -> Error.sexp_of_error e - | ConversionError s -> List [Atom "conversion-error"; Atom s] + | ConversionError s -> List [ Atom "conversion-error"; Atom s ] let wrap_manip = Result.map_error (fun e -> ManipulationError e) diff --git a/lib/listener.ml b/lib/listener.ml index 9d0e67b..e873b3f 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -182,7 +182,10 @@ functor List [ Atom "ok"; - List [ Atom "message"; Atom ("Switched to multigroup " ^ multigroup) ]; + List + [ + Atom "message"; Atom ("Switched to multigroup " ^ multigroup); + ]; ] | Ok (Sublanguage.CreateMultigroup name) -> List diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 4485b35..81da225 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -102,8 +102,7 @@ module Make (Storage : Physical.S with type error = string) = struct ~generator:(Some generator) ~membership_criteria:(fun _ _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name) - ~lineage:(Relation.Lineage.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,6 +129,5 @@ module Make (Storage : Physical.S with type error = string) = struct ~generator:(Some generator) ~membership_criteria:(fun _ _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name) - ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) - () + ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) () end diff --git a/lib/management/merge.ml b/lib/management/merge.ml index a8860fe..dff4808 100644 --- a/lib/management/merge.ml +++ b/lib/management/merge.ml @@ -11,6 +11,7 @@ type strategy = PreferLeft | PreferRight | RevertToAncestor type merge_result = Clean of Database.t | Failed of conflict list (* TODO: Remove this later. We already should have the interface on the manipulation *) + (** Module type for the subset of Manipulation.Make we need. *) module type MANIPULATION = sig type storage @@ -279,9 +280,9 @@ struct all_conflicts in if unresolvable <> [] then Ok (Failed unresolvable) - else begin - match Manip.store_database storage merged_db with + else + begin match Manip.store_database storage merged_db with | Error e -> Error e | Ok () -> Ok (Clean merged_db) - end))) + end))) end diff --git a/lib/manipulation.ml b/lib/manipulation.ml index 31e6079..7ae2753 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -79,7 +79,6 @@ module Make (Storage : Management.Physical.S) = struct let of_string_error s = Error.StorageError s let ( let* ) = Result.bind - let normalize_name n = Qualified_name.(parse n |> to_key) let rec normalize_constraint_body c = @@ -92,7 +91,8 @@ module Make (Storage : Management.Physical.S) = struct body = normalize_constraint_body body; universe = normalize_name universe; } - | Constraint.And cs -> Constraint.And (List.map normalize_constraint_body cs) + | Constraint.And cs -> + Constraint.And (List.map normalize_constraint_body cs) | Constraint.Or cs -> Constraint.Or (List.map normalize_constraint_body cs) | Constraint.Exists { variable; quantifier; body } -> Constraint.Exists @@ -252,8 +252,7 @@ module Make (Storage : Management.Physical.S) = struct ~membership_criteria: (build_membership_criteria ~name:stored.name stored.schema) ~provenance:(Relation.Provenance.Base stored.name) - ~lineage:(Relation.Lineage.Base stored.name) - () + ~lineage:(Relation.Lineage.Base stored.name) () in Ok (Some relation) @@ -319,8 +318,7 @@ module Make (Storage : Management.Physical.S) = struct ~generator:None ~membership_criteria:(build_membership_criteria ~name schema) ~provenance:(Relation.Provenance.Base name) - ~lineage:(Relation.Lineage.Base name) - () + ~lineage:(Relation.Lineage.Base name) () in let new_db = Management.Database.add_relation db ~relation in let* () = store_relation storage relation in @@ -846,8 +844,7 @@ module Make (Storage : Management.Physical.S) = struct ~generator:None ~membership_criteria:(build_membership_criteria ~name schema) ~provenance:(Relation.Provenance.Base name) - ~lineage:(Relation.Lineage.Base name) - () + ~lineage:(Relation.Lineage.Base name) () in let new_db = Management.Database.add_relation db ~relation in let* () = store_relation storage relation in @@ -872,10 +869,9 @@ module Make (Storage : Management.Physical.S) = struct let relation = Relation.make ~hash:(Some relation_hash) ~name ~schema ~tree:None (* No tree for generator-based relations *) - ~constraints:None ~cardinality ~generator:(Some generator) - ~producer ~membership_criteria ~provenance:(Relation.Provenance.Base name) - ~lineage:(Relation.Lineage.Base name) - () + ~constraints:None ~cardinality ~generator:(Some generator) ~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 4b89b4a..c92a89f 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -61,8 +61,7 @@ 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.empty |> Schema.add "name" "string" |> Schema.add "symbol" "string" |> Schema.add "cardinality" "string" |> Schema.add "purity" "string" @@ -165,8 +164,7 @@ 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_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 @@ -190,10 +188,10 @@ let build_function_predicate_tuple ~name ~symbol ~cardinality ~purity : [ ("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) }); + ( "cardinality", + { Attribute.value = Obj.magic (cardinality_to_string cardinality) } + ); + ("purity", { Attribute.value = Obj.magic (purity_to_string purity) }); ]; } @@ -201,7 +199,5 @@ let build_loaded_library_tuple path : Tuple.materialized = { Tuple.relation = loaded_library_rel_name; attributes = - Tuple.AttributeMap.singleton "path" - { Attribute.value = Obj.magic path }; + Tuple.AttributeMap.singleton "path" { Attribute.value = Obj.magic path }; } - diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml index b4f5834..8b0db9f 100644 --- a/lib/prelude/standard.ml +++ b/lib/prelude/standard.ml @@ -17,21 +17,20 @@ let make_comparison ~name ~domain_name ~pred ~cardinality ~generator = in let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool = fun _tree_of -> function - | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "left" m.attributes, - Tuple.AttributeMap.find_opt "right" m.attributes ) - with - | Some l, Some r -> - pred (Stdlib.compare l.Attribute.value r.Attribute.value) - | _ -> false) - | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> ( + match + ( Tuple.AttributeMap.find_opt "left" m.attributes, + Tuple.AttributeMap.find_opt "right" m.attributes ) + with + | Some l, Some r -> + pred (Stdlib.compare l.Attribute.value r.Attribute.value) + | _ -> false) + | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name ~schema ~tree:None ~constraints:None ~cardinality ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base name) - ~lineage:(Relation.Lineage.Base name) - () + ~lineage:(Relation.Lineage.Base name) () (** Enumerate pairs (a, b) where a < b using triangular indexing. *) let pair_of_nat_lt n = @@ -180,25 +179,24 @@ let plus_natural : Relation.t = in let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool = fun _tree_of -> function - | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "sum" m.attributes ) - with - | Some a, Some b, Some s -> - (Obj.magic a.Attribute.value : int) - + (Obj.magic b.Attribute.value : int) - = (Obj.magic s.Attribute.value : int) - | _ -> false) - | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> ( + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "sum" m.attributes ) + with + | Some a, Some b, Some s -> + (Obj.magic a.Attribute.value : int) + + (Obj.magic b.Attribute.value : int) + = (Obj.magic s.Attribute.value : int) + | _ -> false) + | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_plus" ~schema ~tree:None ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "plus") - ~lineage:(Relation.Lineage.Base "plus") - () + ~lineage:(Relation.Lineage.Base "plus") () let times_natural : Relation.t = let schema = @@ -220,25 +218,24 @@ let times_natural : Relation.t = in let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool = fun _tree_of -> function - | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "product" m.attributes ) - with - | Some a, Some b, Some p -> - (Obj.magic a.Attribute.value : int) - * (Obj.magic b.Attribute.value : int) - = (Obj.magic p.Attribute.value : int) - | _ -> false) - | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> ( + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "product" m.attributes ) + with + | Some a, Some b, Some p -> + (Obj.magic a.Attribute.value : int) + * (Obj.magic b.Attribute.value : int) + = (Obj.magic p.Attribute.value : int) + | _ -> false) + | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_times" ~schema ~tree:None ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "times") - ~lineage:(Relation.Lineage.Base "times") - () + ~lineage:(Relation.Lineage.Base "times") () let minus_natural : Relation.t = let schema = @@ -261,26 +258,25 @@ let minus_natural : Relation.t = in let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool = fun _tree_of -> function - | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "difference" m.attributes ) - with - | Some a, Some b, Some d -> - let av = (Obj.magic a.Attribute.value : int) in - let bv = (Obj.magic b.Attribute.value : int) in - let dv = (Obj.magic d.Attribute.value : int) in - av - bv = dv && dv >= 0 - | _ -> false) - | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> ( + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "difference" m.attributes ) + with + | Some a, Some b, Some d -> + let av = (Obj.magic a.Attribute.value : int) in + let bv = (Obj.magic b.Attribute.value : int) in + let dv = (Obj.magic d.Attribute.value : int) in + av - bv = dv && dv >= 0 + | _ -> false) + | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_minus" ~schema ~tree:None ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "minus") - ~lineage:(Relation.Lineage.Base "minus") - () + ~lineage:(Relation.Lineage.Base "minus") () let divide_natural : Relation.t = let schema = @@ -311,37 +307,38 @@ let divide_natural : Relation.t = in let membership_criteria : (string -> Merkle.t option) -> Tuple.t -> bool = fun _tree_of -> function - | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "quotient" m.attributes, - Tuple.AttributeMap.find_opt "remainder" m.attributes ) - with - | Some a, Some b, Some q, Some r -> - let av = (Obj.magic a.Attribute.value : int) in - let bv = (Obj.magic b.Attribute.value : int) in - let qv = (Obj.magic q.Attribute.value : int) in - let rv = (Obj.magic r.Attribute.value : int) in - bv > 0 && av = (bv * qv) + rv && rv >= 0 && rv < bv - | _ -> false) - | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> ( + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "quotient" m.attributes, + Tuple.AttributeMap.find_opt "remainder" m.attributes ) + with + | Some a, Some b, Some q, Some r -> + let av = (Obj.magic a.Attribute.value : int) in + let bv = (Obj.magic b.Attribute.value : int) in + let qv = (Obj.magic q.Attribute.value : int) in + let rv = (Obj.magic r.Attribute.value : int) in + bv > 0 && av = (bv * qv) + rv && rv >= 0 && rv < bv + | _ -> false) + | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_divide" ~schema ~tree:None ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "divide") - ~lineage:(Relation.Lineage.Base "divide") - () + ~lineage:(Relation.Lineage.Base "divide") () let prelude_relations = - [ less_than_natural - ; less_than_or_equal_natural - ; greater_than_natural - ; greater_than_or_equal_natural - ; equal_natural - ; not_equal_natural - ; plus_natural - ; times_natural - ; minus_natural - ; divide_natural ] + [ + less_than_natural; + less_than_or_equal_natural; + greater_than_natural; + greater_than_or_equal_natural; + equal_natural; + not_equal_natural; + plus_natural; + times_natural; + minus_natural; + divide_natural; + ] diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml index d4ceca5..6a53656 100644 --- a/lib/prl/executor.ml +++ b/lib/prl/executor.ml @@ -28,15 +28,18 @@ module Make (Storage : Management.Physical.S) = struct 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 + | 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 + 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) = + 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 -> @@ -48,7 +51,9 @@ module Make (Storage : Management.Physical.S) = struct 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 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 @@ -60,7 +65,8 @@ module Make (Storage : Management.Physical.S) = struct in let fp_tuple = Prelude.Catalog.build_function_predicate_tuple ~name - ~symbol:spec.symbol ~cardinality:spec.cardinality ~purity:spec.purity + ~symbol:spec.symbol ~cardinality:spec.cardinality + ~purity:spec.purity in let* final_db = Ops.create_tuple storage new_db fp_rel fp_tuple diff --git a/lib/prl/runtime.ml b/lib/prl/runtime.ml index d5e28ec..4b746d4 100644 --- a/lib/prl/runtime.ml +++ b/lib/prl/runtime.ml @@ -1,7 +1,4 @@ -type t = { - loaded_libraries : (string, unit) Hashtbl.t; - mutex : Mutex.t; -} +type t = { loaded_libraries : (string, unit) Hashtbl.t; mutex : Mutex.t } let state : t = { loaded_libraries = Hashtbl.create 16; mutex = Mutex.create () } @@ -29,16 +26,15 @@ let to_plugin_row (schema : Schema.t) (tuple : Tuple.materialized) : 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 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) + go (Tuple.AttributeMap.add attr_name { Attribute.value } acc) rest) in go Tuple.AttributeMap.empty schema @@ -51,7 +47,8 @@ let rows_to_generator relation_name schema (rows : Sakura_prl_api.tuple list) : 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." + | None -> + Generator.Error "Plugin row does not conform to predicate schema." | Some tuple -> Generator.Value (Tuple.Materialized tuple, gen (i + 1)) in gen 0 @@ -60,25 +57,25 @@ 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 -> + | 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 + | 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 + 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 -> + | 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)) + | Some row -> ( match check row with Ok b -> b | Error _ -> false))) diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml index b6d01bb..2155f7d 100644 --- a/lib/qualified_name.ml +++ b/lib/qualified_name.ml @@ -6,11 +6,7 @@ - ["mg:schema:relation"] -> { multigroup=mg; schema; relation } *) -type t = { - multigroup : string; - schema : string; - relation : string; -} +type t = { multigroup : string; schema : string; relation : string } let default_schema = "public" diff --git a/lib/qualified_name.mli b/lib/qualified_name.mli index 9bee0c9..5da7555 100644 --- a/lib/qualified_name.mli +++ b/lib/qualified_name.mli @@ -2,23 +2,19 @@ Unqualified names fill in defaults: empty multigroup, ["public"] schema. *) -type t = { - multigroup : string; - schema : string; - relation : string; -} +type t = { multigroup : string; schema : string; relation : string } val default_schema : string -(** Split on [:] with default filling. - - ["rel"] -> multigroup="", schema="public", relation="rel" - - ["s:rel"] -> multigroup="", schema="s", relation="rel" - - ["mg:s:rel"] -> multigroup="mg", schema="s", relation="rel" *) val parse : string -> t +(** Split on [:] with default filling. + - ["rel"] -> multigroup="", schema="public", relation="rel" + - ["s:rel"] -> multigroup="", schema="s", relation="rel" + - ["mg:s:rel"] -> multigroup="mg", schema="s", relation="rel" *) val make : ?multigroup:string -> ?schema:string -> string -> t val to_string : t -> string +val to_key : t -> string (** Composite key for [RelationMap] lookup within a single database: ["schema:relation"]. *) -val to_key : t -> string diff --git a/lib/relation.ml b/lib/relation.ml index 6e6a23c..db7f453 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -44,7 +44,8 @@ type t = { lineage : Lineage.t; } -let make ?(producer = None) ~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; diff --git a/lib/session.ml b/lib/session.ml index a58d00b..a4aef9d 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -54,11 +54,11 @@ let fetch (reg : t) ~(id : string) ~(limit : int) : abnormally. When fetch gains a richer return type this arm should surface the error message instead. *) | Generator.Error _ -> (List.rev acc, gen, pos, false) - | Generator.Value (t, next) -> begin - match t with + | Generator.Value (t, next) -> + begin match t with | Tuple.Materialized m -> go next (pos + 1) (m :: acc) (count + 1) | Tuple.NonMaterialized _ -> go next (pos + 1) acc count - end + end in let rows, gen', pos', has_more = go cur.generator cur.position [] 0 in cur.generator <- gen'; diff --git a/lib/system.ml b/lib/system.ml index 14ef089..40adf82 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -23,21 +23,22 @@ type registry = { let registry : registry = let open Utilities.StringMap in - { storage = + { + storage = empty |> add "memory" (fun sexp -> - let ( let* ) = Result.bind in - let* config = Management.Physical.MemoryBackend.parse sexp in - let* storage = Management.Physical.Memory.create config in - Ok (StorageParcel ((module Management.Physical.Memory), storage))) - ; transport = + let ( let* ) = Result.bind in + let* config = Management.Physical.MemoryBackend.parse sexp in + let* storage = Management.Physical.Memory.create config in + Ok (StorageParcel ((module Management.Physical.Memory), storage))); + transport = empty |> add "tcp" (fun sexp -> - let ( let* ) = Result.bind in - let* config = Transport.TCP.parse sexp in - let transport = Transport.TCP.create config in - Ok (TransportParcel ((module Transport.TCP), transport))) } - + let ( let* ) = Result.bind in + let* config = Transport.TCP.parse sexp in + let transport = Transport.TCP.create config in + Ok (TransportParcel ((module Transport.TCP), transport))); + } let assemble (config : Configuration.t) : (unit -> unit, string) result = let open Utilities.Result in @@ -71,8 +72,10 @@ let assemble (config : Configuration.t) : (unit -> unit, string) result = C.create storage ~prelude_relations:Prelude.Standard.prelude_relations in let module L = Listener.Make (T) (S) in - Ok (fun () -> Scl.Executor.set_sessions (Session.create ()); - L.run transport catalog storage) + Ok + (fun () -> + Scl.Executor.set_sessions (Session.create ()); + L.run transport catalog storage) let run_from_config (path : string) : (unit -> unit, string) result = let ( let* ) = Result.bind in diff --git a/lib/transport.ml b/lib/transport.ml index 8c8a2bd..b541e16 100644 --- a/lib/transport.ml +++ b/lib/transport.ml @@ -22,27 +22,30 @@ module TCP : TRANSPORT = struct let sockaddr_of_fields = function | `Inet (addr, port) -> - Ok { address_family = Unix.PF_INET; - sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port) } + Ok + { + address_family = Unix.PF_INET; + sockaddr = Unix.ADDR_INET (Unix.inet_addr_of_string addr, port); + } | `Unix path -> - Ok { address_family = Unix.PF_UNIX; - sockaddr = Unix.ADDR_UNIX path } + Ok { address_family = Unix.PF_UNIX; sockaddr = Unix.ADDR_UNIX path } let parse sexp = let open Sexplib.Sexp in let errorf fmt = Printf.ksprintf (fun s -> Error s) fmt in let rec go addr port path = function - | [] -> - (match addr, port, path with - | Some a, Some p, None -> sockaddr_of_fields (`Inet (a, p)) - | None, None, Some s -> sockaddr_of_fields (`Unix s) - | None, None, None -> errorf "transport/tcp: no address fields" - | _ -> errorf "transport/tcp: use (address + port) or (path), not both") + | [] -> ( + match (addr, port, path) with + | Some a, Some p, None -> sockaddr_of_fields (`Inet (a, p)) + | None, None, Some s -> sockaddr_of_fields (`Unix s) + | None, None, None -> errorf "transport/tcp: no address fields" + | _ -> + errorf "transport/tcp: use (address + port) or (path), not both") | List [ Atom "address"; Atom a ] :: rest -> go (Some a) port path rest - | List [ Atom "port"; Atom p ] :: rest -> - (match int_of_string_opt p with - | Some n -> go addr (Some n) path rest - | None -> errorf "transport/tcp: invalid port: %s" p) + | List [ Atom "port"; Atom p ] :: rest -> ( + match int_of_string_opt p with + | Some n -> go addr (Some n) path rest + | None -> errorf "transport/tcp: invalid port: %s" p) | List [ Atom "path"; Atom p ] :: rest -> go addr port (Some p) rest | bad :: _ -> errorf "transport/tcp: unexpected: %s" (to_string bad) in @@ -63,7 +66,8 @@ module TCP : TRANSPORT = struct let listen fd = Unix.listen fd 5; - Printf.printf "Listening on %s\n%!" (string_of_sockaddr (Unix.getsockname fd)) + Printf.printf "Listening on %s\n%!" + (string_of_sockaddr (Unix.getsockname fd)) let accept fd = let conn, _ = Unix.accept fd in diff --git a/lib/utilities.ml b/lib/utilities.ml index d0c5673..34b0eb1 100644 --- a/lib/utilities.ml +++ b/lib/utilities.ml @@ -2,9 +2,9 @@ module StringMap = Map.Make (String) module StringSet = Set.Make (String) module Result = struct - let (let*) = Result.bind + let ( let* ) = Result.bind end module Option = struct - let (let*) = Option.bind + let ( let* ) = Option.bind end diff --git a/prl_api/sakura_prl_api.ml b/prl_api/sakura_prl_api.ml index 92fd658..84337fb 100644 --- a/prl_api/sakura_prl_api.ml +++ b/prl_api/sakura_prl_api.ml @@ -15,12 +15,14 @@ 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 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 = +let implementation_of_rows ?membership_criteria (rows : tuple list) : + implementation = { membership_criteria; produce = Some (fun _bindings -> Ok rows) } let implementation_of_producer ?membership_criteria diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml index 12fac52..932089f 100644 --- a/test/test_relational_engine.ml +++ b/test/test_relational_engine.ml @@ -1,7 +1,6 @@ (** Tests for the relational engine *) open Relational_engine - module Memory = Manipulation.Make (Management.Physical.Memory) let%test_unit "merkle: empty tree" = @@ -149,8 +148,7 @@ let%test_unit "database: add relation" = ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") - () + ~lineage:(Relation.Lineage.Base "users") () in let db = Management.Database.add_relation db ~relation in assert (Management.Database.has_relation db "users"); @@ -165,8 +163,7 @@ let%test_unit "database: remove relation" = ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") - () + ~lineage:(Relation.Lineage.Base "users") () in let db = Management.Database.add_relation db ~relation in assert (Management.Database.has_relation db "users"); @@ -181,8 +178,7 @@ let%test_unit "database: update relation" = ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") - () + ~lineage:(Relation.Lineage.Base "users") () in let db = Management.Database.add_relation db ~relation in let old_db_hash = db.hash in @@ -200,8 +196,7 @@ let%test_unit "database: get relation names" = ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "users") - () + ~lineage:(Relation.Lineage.Base "users") () in let rel2 = Relation.make ~hash:(Some "h2") ~name:"orders" ~schema:Schema.empty @@ -209,8 +204,7 @@ let%test_unit "database: get relation names" = ~cardinality:(Conventions.Cardinality.Finite 0) ~generator:None ~membership_criteria:(fun _ _ -> true) ~provenance:Relation.Provenance.Undefined - ~lineage:(Relation.Lineage.Base "orders") - () + ~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 @@ -244,9 +238,7 @@ let%test_unit "manipulation: create relation" = let schema = Schema.empty |> Schema.add "name" "string" |> Schema.add "age" "integer" in - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, relation) -> assert (relation.name = "users"); @@ -261,14 +253,10 @@ let%test_unit "manipulation: create relation already exists" = | Ok db -> db in let schema = Schema.empty in - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> ( - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error (Error.RelationAlreadyExists _) -> () | _ -> assert false)) @@ -280,15 +268,11 @@ let%test_unit "manipulation: retract relation" = | Ok db -> db in let schema = Schema.empty in - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> ( assert (Management.Database.has_relation db "users"); - match - Memory.retract_relation storage db ~name:"users" - with + match Memory.retract_relation storage db ~name:"users" with | Error _ -> assert false | Ok db -> assert (not (Management.Database.has_relation db "users")))) @@ -300,9 +284,7 @@ let%test_unit "manipulation: create tuple with storage" = | Ok db -> db in let schema = Schema.empty |> Schema.add "name" "string" in - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let attrs = @@ -326,9 +308,7 @@ let%test_unit "manipulation: create and load tuple" = | Ok db -> db in let schema = Schema.empty |> Schema.add "value" "integer" in - match - Memory.create_relation storage db ~name:"numbers" ~schema - with + match Memory.create_relation storage db ~name:"numbers" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let attrs = @@ -360,9 +340,7 @@ let%test_unit "manipulation: create multiple tuples with storage" = | Ok db -> db in let schema = Schema.empty |> Schema.add "id" "integer" in - match - Memory.create_relation storage db ~name:"items" ~schema - with + match Memory.create_relation storage db ~name:"items" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let make_tuple id = @@ -374,9 +352,7 @@ let%test_unit "manipulation: create multiple tuples with storage" = : Tuple.materialized) in let tuples = [ make_tuple 1; make_tuple 2; make_tuple 3 ] in - match - Memory.create_tuples storage db relation tuples - with + match Memory.create_tuples storage db relation tuples with | Error _ -> assert false | Ok (_db, new_relation, hashes) -> assert (Memory.tuple_count new_relation = 3); @@ -390,9 +366,7 @@ let%test_unit "manipulation: load multiple tuples" = | Ok db -> db in let schema = Schema.empty |> Schema.add "n" "integer" in - match - Memory.create_relation storage db ~name:"test" ~schema - with + match Memory.create_relation storage db ~name:"test" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let make_tuple n = @@ -433,9 +407,7 @@ let%test_unit "manipulation: retract tuple" = | Ok db -> db in let schema = Schema.empty |> Schema.add "value" "integer" in - match - Memory.create_relation storage db ~name:"numbers" ~schema - with + match Memory.create_relation storage db ~name:"numbers" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let attrs = @@ -449,10 +421,7 @@ let%test_unit "manipulation: retract tuple" = | Error _ -> assert false | Ok (db, relation, tuple_hash) -> ( assert (Memory.tuple_count relation = 1); - match - Memory.retract_tuple storage db relation - ~tuple_hash - with + match Memory.retract_tuple storage db relation ~tuple_hash with | Error _ -> assert false | Ok (_db, relation) -> ( assert (Memory.tuple_count relation = 0); @@ -470,9 +439,7 @@ let%test_unit "manipulation: tuple hashes" = | Ok db -> db in let schema = Schema.empty in - match - Memory.create_relation storage db ~name:"test" ~schema - with + match Memory.create_relation storage db ~name:"test" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let make_tuple n = @@ -500,9 +467,7 @@ let%test_unit "manipulation: clear relation" = | Ok db -> db in let schema = Schema.empty in - match - Memory.create_relation storage db ~name:"test" ~schema - with + match Memory.create_relation storage db ~name:"test" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let make_tuple n = @@ -522,8 +487,7 @@ let%test_unit "manipulation: clear relation" = assert (Memory.tuple_count relation = 3); match Memory.clear_relation storage db relation with | Error _ -> assert false - | Ok (_db, relation) -> - assert (Memory.tuple_count relation = 0)))) + | Ok (_db, relation) -> assert (Memory.tuple_count relation = 0)))) let%test_unit "manipulation: duplicate tuple rejected" = with_storage (fun storage -> @@ -533,9 +497,7 @@ let%test_unit "manipulation: duplicate tuple rejected" = | Ok db -> db in let schema = Schema.empty |> Schema.add "x" "integer" in - match - Memory.create_relation storage db ~name:"test" ~schema - with + match Memory.create_relation storage db ~name:"test" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let attrs = @@ -549,9 +511,7 @@ let%test_unit "manipulation: duplicate tuple rejected" = | Error _ -> assert false | Ok (db, relation, _) -> ( (* Try to insert the same tuple again *) - match - Memory.create_tuple storage db relation tuple - with + match Memory.create_tuple storage db relation tuple with | Error (Error.DuplicateTuple _) -> () | _ -> assert false))) @@ -563,9 +523,7 @@ let%test_unit "manipulation: tuple_exists check" = | Ok db -> db in let schema = Schema.empty in - match - Memory.create_relation storage db ~name:"test" ~schema - with + match Memory.create_relation storage db ~name:"test" ~schema with | Error _ -> assert false | Ok (db, relation) -> ( let attrs = @@ -621,9 +579,7 @@ let%test_unit "manipulation: get_relation from database" = | Ok db -> db in let schema = Schema.empty |> Schema.add "id" "integer" in - match - Memory.create_relation storage db ~name:"items" ~schema - with + match Memory.create_relation storage db ~name:"items" ~schema with | Error _ -> assert false | Ok (db, _relation) -> ( (* Now get the relation from the database *) @@ -644,9 +600,7 @@ let%test_unit "schema: persisted and loaded correctly" = Schema.empty |> Schema.add "id" "integer" |> Schema.add "name" "string" |> Schema.add "email" "string" in - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _relation) -> ( (* Get the relation hash *) @@ -680,9 +634,7 @@ let%test_unit "catalog: sakura:relation contains all 6 catalog names" = | Error _ -> assert false | Ok db -> let rel = - match - Memory.get_relation db ~name:"sakura:relation" - with + match Memory.get_relation db ~name:"sakura:relation" with | None -> assert false | Some r -> r in @@ -732,16 +684,13 @@ let%test_unit "catalog: create_relation updates sakura:relation" = let schema = Schema.empty |> Schema.add "id" "natural" in let db = match - Memory.create_relation storage db ~name:"employees" - ~schema + Memory.create_relation storage db ~name:"employees" ~schema with | Error _ -> assert false | Ok (db, _) -> db in let rel = - match - Memory.get_relation db ~name:"sakura:relation" - with + match Memory.get_relation db ~name:"sakura:relation" with | None -> assert false | Some r -> r in @@ -756,16 +705,13 @@ let%test_unit "catalog: create_relation updates sakura:attribute" = let schema = Schema.empty |> Schema.add "id" "natural" in let db = match - Memory.create_relation storage db ~name:"employees" - ~schema + Memory.create_relation storage db ~name:"employees" ~schema with | Error _ -> assert false | Ok (db, _) -> db in let attr_rel = - match - Memory.get_relation db ~name:"sakura:attribute" - with + match Memory.get_relation db ~name:"sakura:attribute" with | None -> assert false | Some r -> r in @@ -783,23 +729,18 @@ let%test_unit "catalog: retract_relation removes from sakura:relation" = let schema = Schema.empty |> Schema.add "id" "natural" in let db = match - Memory.create_relation storage db ~name:"employees" - ~schema + Memory.create_relation storage db ~name:"employees" ~schema with | Error _ -> assert false | Ok (db, _) -> db in let db = - match - Memory.retract_relation storage db ~name:"employees" - with + match Memory.retract_relation storage db ~name:"employees" with | Error _ -> assert false | Ok db -> db in let rel = - match - Memory.get_relation db ~name:"sakura:relation" - with + match Memory.get_relation db ~name:"sakura:relation" with | None -> assert false | Some r -> r in @@ -813,10 +754,7 @@ let%test_unit "catalog: register_constraint inserts into sakura:constraint" = | Ok db -> let schema = Schema.empty |> Schema.add "id" "natural" in let db = - match - Memory.create_relation storage db ~name:"orders" - ~schema - with + match Memory.create_relation storage db ~name:"orders" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -830,9 +768,7 @@ let%test_unit "catalog: register_constraint inserts into sakura:constraint" = | Ok db -> db in let con_rel = - match - Memory.get_relation db ~name:"sakura:constraint" - with + match Memory.get_relation db ~name:"sakura:constraint" with | None -> assert false | Some r -> r in @@ -854,10 +790,7 @@ let%test_unit "integration: full workflow with storage" = in let db, products = - match - Memory.create_relation storage db ~name:"products" - ~schema - with + match Memory.create_relation storage db ~name:"products" ~schema with | Error _ -> assert false | Ok x -> x in @@ -901,8 +834,7 @@ let%test_unit "integration: full workflow with storage" = let banana_hash = Hashing.hash_tuple (make_product 2 "Banana" 50) in let _db, products = match - Memory.retract_tuple storage db products - ~tuple_hash:banana_hash + Memory.retract_tuple storage db products ~tuple_hash:banana_hash with | Error _ -> assert false | Ok x -> x @@ -934,9 +866,7 @@ let%test_unit "integration: database history tracking" = let schema = Schema.empty in let db, _ = - match - Memory.create_relation storage db ~name:"rel1" ~schema - with + match Memory.create_relation storage db ~name:"rel1" ~schema with | Error _ -> assert false | Ok x -> x in @@ -947,9 +877,7 @@ let%test_unit "integration: database history tracking" = let hash_after_rel1 = db.hash in let db, _ = - match - Memory.create_relation storage db ~name:"rel2" ~schema - with + match Memory.create_relation storage db ~name:"rel2" ~schema with | Error _ -> assert false | Ok x -> x in @@ -968,9 +896,7 @@ let%test_unit "integration: hash bubbles up correctly" = let schema = Schema.empty in let db, relation = - match - Memory.create_relation storage db ~name:"items" ~schema - with + match Memory.create_relation storage db ~name:"items" ~schema with | Error _ -> assert false | Ok x -> x in @@ -1018,9 +944,7 @@ let%test_unit "branching: load database from historical hash" = (* Create relation and add a tuple *) let db, relation = - match - Memory.create_relation storage db ~name:"items" ~schema - with + match Memory.create_relation storage db ~name:"items" ~schema with | Error _ -> assert false | Ok x -> x in @@ -1092,9 +1016,7 @@ let%test_unit "branching: branch from historical state" = (* Create relation *) let db, relation = - match - Memory.create_relation storage db ~name:"data" ~schema - with + match Memory.create_relation storage db ~name:"data" ~schema with | Error _ -> assert false | Ok x -> x in @@ -1153,10 +1075,7 @@ let%test_unit "branching: branch from historical state" = } in let db_branch, _relation_branch, _ = - match - Memory.create_tuple storage db_branch relation_branch - tuple_c - with + match Memory.create_tuple storage db_branch relation_branch tuple_c with | Error _ -> assert false | Ok x -> x in @@ -1190,10 +1109,7 @@ let%test_unit "branching: full reconstruction from hash" = (* Create relation *) let db, relation = - match - Memory.create_relation storage db ~name:"products" - ~schema - with + match Memory.create_relation storage db ~name:"products" ~schema with | Error _ -> assert false | Ok x -> x in @@ -1350,9 +1266,7 @@ let%test_unit "algebra: project restricts schema" = Schema.empty |> Schema.add "a" "integer" |> Schema.add "b" "integer" in let db, rel = - match - Memory.create_relation storage db ~name:"ab" ~schema - with + match Memory.create_relation storage db ~name:"ab" ~schema with | Error _ -> assert false | Ok x -> x in @@ -1417,10 +1331,7 @@ let%test_unit "algebra: equijoin merges matching tuples" = Schema.empty |> Schema.add "id" "integer" |> Schema.add "name" "string" in let db, left = - match - Memory.create_relation storage db ~name:"L" - ~schema:schema_l - with + match Memory.create_relation storage db ~name:"L" ~schema:schema_l with | Error _ -> assert false | Ok x -> x in @@ -1448,10 +1359,7 @@ let%test_unit "algebra: equijoin merges matching tuples" = |> Schema.add "score" "integer" in let db, right = - match - Memory.create_relation storage db ~name:"R" - ~schema:schema_r - with + match Memory.create_relation storage db ~name:"R" ~schema:schema_r with | Error _ -> assert false | Ok x -> x in @@ -1644,9 +1552,7 @@ let%test_unit "drl: execute Select+Const" = Schema.empty |> Schema.add "age" "integer" |> Schema.add "name" "string" in let db, users = - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok x -> x in @@ -2026,19 +1932,15 @@ let%test_unit "constraint: create_tuple with passing constraint" = in let schema = Schema.empty |> Schema.add "value" "natural" in let db, _rel = - match - Memory.create_relation storage db ~name:"positives" - ~schema - with + match Memory.create_relation storage db ~name:"positives" ~schema with | Error _ -> assert false | Ok x -> x in (* Register a constraint: value must be member of natural (always true for naturals) *) let db = match - Memory.register_constraint storage db - ~constraint_name:"is_natural" ~relation_name:"positives" - ~body:(Constraint.And []) + Memory.register_constraint storage db ~constraint_name:"is_natural" + ~relation_name:"positives" ~body:(Constraint.And []) with | Error _ -> assert false | Ok db -> db @@ -2069,17 +1971,15 @@ let%test_unit "constraint: create_tuple with failing constraint" = in let schema = Schema.empty |> Schema.add "value" "natural" in let db, _rel = - match - Memory.create_relation storage db ~name:"checked" ~schema - with + match Memory.create_relation storage db ~name:"checked" ~schema with | Error _ -> assert false | Ok x -> x in (* Register a constraint that always fails: MemberOf a nonexistent relation *) let db = match - Memory.register_constraint storage db - ~constraint_name:"impossible" ~relation_name:"checked" + Memory.register_constraint storage db ~constraint_name:"impossible" + ~relation_name:"checked" ~body: (Constraint.MemberOf { @@ -2121,17 +2021,12 @@ let%test_unit "constraint scenario: mutual exclusion subtypes" = in let schema = Schema.empty |> Schema.add "id" "natural" in let db, _employee = - match - Memory.create_relation storage db ~name:"employee" - ~schema - with + match Memory.create_relation storage db ~name:"employee" ~schema with | Error _ -> assert false | Ok x -> x in let db, _manager = - match - Memory.create_relation storage db ~name:"manager" ~schema - with + match Memory.create_relation storage db ~name:"manager" ~schema with | Error _ -> assert false | Ok x -> x in @@ -2151,8 +2046,8 @@ let%test_unit "constraint scenario: mutual exclusion subtypes" = in let db = match - Memory.register_constraint storage db - ~constraint_name:"not_employee" ~relation_name:"manager" ~body + Memory.register_constraint storage db ~constraint_name:"not_employee" + ~relation_name:"manager" ~body with | Error _ -> assert false | Ok db -> db @@ -2171,9 +2066,7 @@ let%test_unit "constraint scenario: mutual exclusion subtypes" = } in let db, _employee, _ = - match - Memory.create_tuple storage db employee emp_tuple - with + match Memory.create_tuple storage db employee emp_tuple with | Error _ -> assert false | Ok x -> x in @@ -2205,8 +2098,7 @@ let%test_unit "constraint scenario: foreign key" = let order_schema = Schema.empty |> Schema.add "order_id" "natural" in let db, _orders = match - Memory.create_relation storage db ~name:"orders" - ~schema:order_schema + Memory.create_relation storage db ~name:"orders" ~schema:order_schema with | Error _ -> assert false | Ok x -> x @@ -2236,9 +2128,8 @@ let%test_unit "constraint scenario: foreign key" = in let db = match - Memory.register_constraint storage db - ~constraint_name:"fk_order" ~relation_name:"order_items" - ~body:fk_body + Memory.register_constraint storage db ~constraint_name:"fk_order" + ~relation_name:"order_items" ~body:fk_body with | Error _ -> assert false | Ok db -> db @@ -2258,9 +2149,7 @@ let%test_unit "constraint scenario: foreign key" = } in let db, _orders, _ = - match - Memory.create_tuple storage db orders order_tuple - with + match Memory.create_tuple storage db orders order_tuple with | Error _ -> assert false | Ok x -> x in @@ -2316,18 +2205,14 @@ let%test_unit "constraint scenario: self-reference neq" = |> Schema.add "mgr_id" "natural" in let db, _rel = - match - Memory.create_relation storage db ~name:"reports_to" - ~schema - with + match Memory.create_relation storage db ~name:"reports_to" ~schema with | Error _ -> assert false | Ok x -> x in (* Register the not_equal comparison relation *) let db, _ = match - Memory.create_immutable_relation storage db - ~name:"not_equal" + Memory.create_immutable_relation storage db ~name:"not_equal" ~schema: (Schema.empty |> Schema.add "left" "natural" @@ -2345,8 +2230,7 @@ let%test_unit "constraint scenario: self-reference neq" = <> (Obj.obj r.Attribute.value : int) | _ -> false) | _ -> false) - ~cardinality:Conventions.Cardinality.AlephZero - ~producer:None + ~cardinality:Conventions.Cardinality.AlephZero ~producer:None with | Error _ -> assert false | Ok x -> x @@ -2412,17 +2296,13 @@ let%test_unit "constraint scenario: open vs closed ticket" = in let schema = Schema.empty |> Schema.add "ticket_id" "natural" in let db, _ = - match - Memory.create_relation storage db ~name:"open_ticket" - ~schema - with + match Memory.create_relation storage db ~name:"open_ticket" ~schema with | Error _ -> assert false | Ok x -> x in let db, _ = match - Memory.create_relation storage db ~name:"closed_ticket" - ~schema + Memory.create_relation storage db ~name:"closed_ticket" ~schema with | Error _ -> assert false | Ok x -> x @@ -2430,8 +2310,8 @@ let%test_unit "constraint scenario: open vs closed ticket" = (* open_ticket must not be in closed_ticket *) let db = match - Memory.register_constraint storage db - ~constraint_name:"not_closed" ~relation_name:"open_ticket" + Memory.register_constraint storage db ~constraint_name:"not_closed" + ~relation_name:"open_ticket" ~body: (Constraint.Not { @@ -2497,8 +2377,7 @@ let%test_unit "constraint scenario: weak entity dependency" = let parent_schema = Schema.empty |> Schema.add "parent_id" "natural" in let db, _ = match - Memory.create_relation storage db ~name:"parent" - ~schema:parent_schema + Memory.create_relation storage db ~name:"parent" ~schema:parent_schema with | Error _ -> assert false | Ok x -> x @@ -2510,8 +2389,7 @@ let%test_unit "constraint scenario: weak entity dependency" = in let db, _ = match - Memory.create_relation storage db ~name:"dependent" - ~schema:dep_schema + Memory.create_relation storage db ~name:"dependent" ~schema:dep_schema with | Error _ -> assert false | Ok x -> x @@ -2519,8 +2397,8 @@ let%test_unit "constraint scenario: weak entity dependency" = (* dependent.parent_id must exist in parent *) let db = match - Memory.register_constraint storage db - ~constraint_name:"parent_exists" ~relation_name:"dependent" + Memory.register_constraint storage db ~constraint_name:"parent_exists" + ~relation_name:"dependent" ~body: (Constraint.MemberOf { @@ -2600,18 +2478,14 @@ let%test_unit "constraint propagation: select preserves constraints" = in let schema = Schema.empty |> Schema.add "x" "natural" in let db, _rel = - match - Memory.create_relation storage db ~name:"constrained" - ~schema - with + match Memory.create_relation storage db ~name:"constrained" ~schema with | Error _ -> assert false | Ok x -> x in let db = match - Memory.register_constraint storage db - ~constraint_name:"c1" ~relation_name:"constrained" - ~body:(Constraint.And []) + Memory.register_constraint storage db ~constraint_name:"c1" + ~relation_name:"constrained" ~body:(Constraint.And []) with | Error _ -> assert false | Ok db -> db @@ -2637,9 +2511,7 @@ let%test_unit "constraint propagation: project filters constraints" = Schema.empty |> Schema.add "x" "natural" |> Schema.add "y" "natural" in let db, _rel = - match - Memory.create_relation storage db ~name:"xy" ~schema - with + match Memory.create_relation storage db ~name:"xy" ~schema with | Error _ -> assert false | Ok x -> x in @@ -2654,8 +2526,8 @@ let%test_unit "constraint propagation: project filters constraints" = in let db = match - Memory.register_constraint storage db - ~constraint_name:"x_only" ~relation_name:"xy" ~body:c_on_x + Memory.register_constraint storage db ~constraint_name:"x_only" + ~relation_name:"xy" ~body:c_on_x with | Error _ -> assert false | Ok db -> db @@ -2799,7 +2671,6 @@ let%test_unit "prl: define predicate and query via DRL" = | 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" = @@ -2837,9 +2708,7 @@ let%test_unit "dml: execute InsertTuple" = in let schema = Schema.empty |> Schema.add "name" "string" in let db = - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -2866,9 +2735,7 @@ let%test_unit "dml: execute InsertTuples" = in let schema = Schema.empty |> Schema.add "name" "string" in let db = - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -2902,9 +2769,7 @@ let%test_unit "dml: execute DeleteTuple" = in let schema = Schema.empty |> Schema.add "name" "string" in let db = - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -2943,9 +2808,7 @@ let%test_unit "ddl: execute RetractRelation" = in let schema = Schema.empty in let db = - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -2965,9 +2828,7 @@ let%test_unit "ddl: execute ClearRelation" = in let schema = Schema.empty |> Schema.add "name" "string" in let db = - match - Memory.create_relation storage db ~name:"users" ~schema - with + match Memory.create_relation storage db ~name:"users" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -3113,10 +2974,7 @@ let%test_unit "dcl: execute RegisterConstraint attaches constraint" = in let schema = Schema.empty |> Schema.add "order_id" "natural" in let db = - match - Memory.create_relation storage db ~name:"order_items" - ~schema - with + match Memory.create_relation storage db ~name:"order_items" ~schema with | Error _ -> assert false | Ok (db, _) -> db in @@ -3224,8 +3082,8 @@ let%test_unit "dcl: FK constraint enforced on insert" = }) with | Error - (Dml.Executor.Memory.ManipulationError - (Error.ConstraintViolation _)) -> + (Dml.Executor.Memory.ManipulationError (Error.ConstraintViolation _)) + -> () | _ -> assert false) @@ -3332,8 +3190,7 @@ let%test_unit "diff: added relation detected" = let schema = Schema.empty |> Schema.add "x" "natural" in let target, _ = match - Memory.create_relation storage ancestor ~name:"new_rel" - ~schema + Memory.create_relation storage ancestor ~name:"new_rel" ~schema with | Error _ -> assert false | Ok p -> p @@ -3355,17 +3212,12 @@ let%test_unit "diff: removed relation detected" = | Ok db -> db in let ancestor, _ = - match - Memory.create_relation storage ancestor ~name:"gone" - ~schema - with + match Memory.create_relation storage ancestor ~name:"gone" ~schema with | Error _ -> assert false | Ok p -> p in let target = - match - Memory.retract_relation storage ancestor ~name:"gone" - with + match Memory.retract_relation storage ancestor ~name:"gone" with | Error _ -> assert false | Ok db -> db in @@ -3386,9 +3238,7 @@ let%test_unit "diff: modified relation detected with added tuple" = | Ok db -> db in let ancestor, _ = - match - Memory.create_relation storage ancestor ~name:"r" ~schema - with + match Memory.create_relation storage ancestor ~name:"r" ~schema with | Error _ -> assert false | Ok p -> p in @@ -3417,8 +3267,7 @@ let%test_unit "diff: modified relation detected with added tuple" = assert (removed_tuples = []) | _ -> assert false) -module MergeMemory = - Management.Merge.Make (Management.Physical.Memory) (Memory) +module MergeMemory = Management.Merge.Make (Management.Physical.Memory) (Memory) let%test_unit "merge: fast-forward when only one side changed" = with_storage (fun storage -> @@ -3429,9 +3278,7 @@ let%test_unit "merge: fast-forward when only one side changed" = | Ok db -> db in let base_db, _ = - match - Memory.create_relation storage base_db ~name:"r" ~schema - with + match Memory.create_relation storage base_db ~name:"r" ~schema with | Error _ -> assert false | Ok p -> p in @@ -3476,9 +3323,7 @@ let%test_unit "merge: independent tuple additions produce union" = | Ok db -> db in let base_db, _ = - match - Memory.create_relation storage base_db ~name:"r" ~schema - with + match Memory.create_relation storage base_db ~name:"r" ~schema with | Error _ -> assert false | Ok p -> p in @@ -3999,8 +3844,8 @@ let setup_fk_db storage = in let db = match - Memory.register_constraint storage db - ~constraint_name:"fk_dept" ~relation_name:"Employee" ~body:fk_body + Memory.register_constraint storage db ~constraint_name:"fk_dept" + ~relation_name:"Employee" ~body:fk_body with | Error _ -> assert false | Ok db -> db @@ -4087,13 +3932,9 @@ let%test_unit "cascade: delete referenced row violates FK and is rejected" = } in (* Deleting Dept 1 while Employee references it must fail *) - match - Memory.retract_tuple storage db dept_rel - ~tuple_hash:dept_hash - with + match Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with | Ok _ -> assert false (* should have been rejected *) - | Error (Error.ConstraintViolation msg) -> - assert (String.length msg > 0) + | Error (Error.ConstraintViolation msg) -> assert (String.length msg > 0) | Error _ -> assert false) let%test_unit "cascade: delete unreferenced row succeeds" = @@ -4152,16 +3993,11 @@ let%test_unit "cascade: delete unreferenced row succeeds" = } in (* Deleting unreferenced Dept 2 must succeed *) - match - Memory.retract_tuple storage db dept_rel - ~tuple_hash:dept2_hash - with + match Memory.retract_tuple storage db dept_rel ~tuple_hash:dept2_hash with | Error _ -> assert false | Ok (new_db, _) -> let dept = - match - Memory.get_relation new_db ~name:"Department" - with + match Memory.get_relation new_db ~name:"Department" with | None -> assert false | Some r -> r in @@ -4252,9 +4088,7 @@ let%test_unit "cascade: Negative-polarity relation deletion is not checked" = } in (* Deleting from Blacklist (negative polarity) must not trigger cascade check *) - match - Memory.retract_tuple storage db bl_rel ~tuple_hash:bl_hash - with + match Memory.retract_tuple storage db bl_rel ~tuple_hash:bl_hash with | Error _ -> assert false | Ok _ -> ()) @@ -4345,16 +4179,11 @@ let%test_unit "cascade: deferred constraint not checked during retract_tuple" = } in (* Deferred: retract_tuple itself should NOT reject the deletion *) - match - Memory.retract_tuple storage db dept_rel - ~tuple_hash:dept_hash - with + match Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with | Error _ -> assert false (* deferred: must pass here *) | Ok (new_db, _) -> ( (* But check_deferred_constraints must catch the violation *) - match - Memory.check_deferred_constraints storage new_db - with + match Memory.check_deferred_constraints storage new_db with | Ok () -> assert false (* should have caught the violation *) | Error (Error.ConstraintViolation _) -> () | Error _ -> assert false)) @@ -4407,9 +4236,8 @@ let setup_blacklist_db storage = } in match - Memory.register_constraint storage db - ~constraint_name:"not_blacklisted" ~relation_name:"Employee" - ~body:not_body + Memory.register_constraint storage db ~constraint_name:"not_blacklisted" + ~relation_name:"Employee" ~body:not_body with | Error _ -> assert false | Ok db -> db @@ -4605,8 +4433,7 @@ let%test_unit "commit: deferred violation is caught at commit boundary" = (* Delete the referenced department. Deferred, so retract succeeds *) let db = match - Memory.retract_tuple storage db dept_rel - ~tuple_hash:dept_hash + Memory.retract_tuple storage db dept_rel ~tuple_hash:dept_hash with | Error _ -> assert false | Ok (db, _) -> db |