diff options
| author | Marcos Magueta <maguetamarcos@gmail.com> | 2026-06-23 23:53:26 -0300 |
|---|---|---|
| committer | GitHub <noreply@github.com> | 2026-06-23 23:53:26 -0300 |
| commit | c284fcd570342c31bc21169960579a20a763e32e (patch) | |
| tree | ce7485055116d794c55090ad0978e0b3f5ff4c2a /lib | |
| parent | b81586ee4a0543a5f9866586c78dccdd6328934a (diff) | |
| download | Sakura-c284fcd570342c31bc21169960579a20a763e32e.tar.gz Sakura-c284fcd570342c31bc21169960579a20a763e32e.zip | |
Format
Diffstat (limited to '')
60 files changed, 1760 insertions, 2286 deletions
diff --git a/lib/algebra.ml b/lib/algebra.ml index 9c620ee..5416f65 100644 --- a/lib/algebra.ml +++ b/lib/algebra.ml @@ -10,26 +10,22 @@ type error = UnsupportedOperator of string REPL exploration; it does not go through the VM. TODO: materialise const tuples into InMemoryBackend and SCAN them so they can participate in VM JOINs. *) -let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : - Relation.ephemeral = +let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : Relation.ephemeral = let make_gen () = let attrs = List.fold_left - (fun acc (k, v) -> Tuple.AttributeMap.add k { Attribute.value = v } acc) + (fun acc (k, v) -> Tuple.AttributeMap.add k {Attribute.value= v} acc) Tuple.AttributeMap.empty pairs in - let tuple = - Tuple.Materialized { Tuple.relation = "const"; attributes = attrs } - in + let tuple = Tuple.Materialized {Tuple.relation= "const"; attributes= attrs} in let gen = function | None | Some 0 -> Generator.Value (tuple, fun _ -> Generator.Done) - | _ -> Generator.Done + | _ -> Generator.Done in gen in - let schema = List.map (fun (k, _) -> (k, "abstract")) pairs in - new Relation.ephemeral ~name:"const" ~schema ~constraints:None - ~cardinality:(Conventions.Cardinality.Finite 1) + let schema = List.map (fun (k, _) -> k, "abstract") pairs in + new Relation.ephemeral + ~name:"const" ~schema ~constraints:None ~cardinality:(Conventions.Cardinality.Finite 1) ~membership_criteria:(fun _ -> true) - ~lineage:None ~provenance:None - ~generator:(make_gen ()) + ~lineage:None ~provenance:None ~generator:(make_gen ()) diff --git a/lib/attribute.ml b/lib/attribute.ml index 8448bee..dc0e178 100644 --- a/lib/attribute.ml +++ b/lib/attribute.ml @@ -1,13 +1,10 @@ -type referenced = { value_hash : Conventions.Hash.t } [@@deriving sexp_of] -type materialized = { value : Conventions.AbstractValue.t } [@@deriving sexp_of] - -type t = Referenced of referenced | Materialized of materialized -[@@deriving sexp_of] +type referenced = {value_hash: Conventions.Hash.t} [@@deriving sexp_of] +type materialized = {value: Conventions.AbstractValue.t} [@@deriving sexp_of] +type t = Referenced of referenced | Materialized of materialized [@@deriving sexp_of] let make_referenced ~value = let value_hash = Conventions.AbstractValue.hash value in - Referenced { value_hash } - -let make_materialized ~value = Materialized { value } + Referenced {value_hash} +let make_materialized ~value = Materialized {value} let materialized_equal a b = Conventions.AbstractValue.equal a.value b.value diff --git a/lib/branch.ml b/lib/branch.ml index f606d3f..e153fa2 100644 --- a/lib/branch.ml +++ b/lib/branch.ml @@ -5,6 +5,7 @@ module Make (NT : Nt.S) = struct module Error = struct open Condition + (* TODO: more structure *) let not_supported msg = condition "not-supported" msg empty let handle_error msg = condition "handle-error" msg empty @@ -13,174 +14,155 @@ module Make (NT : Nt.S) = struct let ( let* ) = Result.bind type mode = - | Live (* tracking branch tip; mutations allowed *) - | Detached of string (* pinned to snapshot hash; read-only *) - - class branch - ~(init_bh : Nt.branch_handle) - ~(init_name : string) - ~(init_tip : string) - ~(init_mgs : (string * Management.Multigroup.multigroup) list) - ~(init_mode : mode) = - object (self) - val mutable bh : Nt.branch_handle = init_bh - val name : string = init_name - val mutable tip : string = init_tip - val mutable mode : mode = init_mode - val mgs : (string, Management.Multigroup.multigroup) Hashtbl.t = - let t = Hashtbl.create 8 in - List.iter (fun (n, mg) -> Hashtbl.replace t n mg) init_mgs; - t - - method name = name - method tip = tip - method snapshot = tip - method mode = mode - method branch_handle = bh - - method mg_of (n : string) : Management.Multigroup.multigroup option = - Hashtbl.find_opt mgs n - - method multigroups : (string * Management.Multigroup.multigroup) list = - Hashtbl.to_seq mgs |> List.of_seq - - (* Register a fresh mg under this branch. Idempotent. *) - method add_multigroup ~(name : string) : unit = - if not (Hashtbl.mem mgs name) then - Hashtbl.add mgs name (new Management.Multigroup.multigroup ~name) - - (* Replace the cached mg value (e.g. after an NT mutation returned a + | Live (* tracking branch tip; mutations allowed *) + | Detached of string (* pinned to snapshot hash; read-only *) + + class branch ~(init_bh : Nt.branch_handle) ~(init_name : string) ~(init_tip : string) + ~(init_mgs : (string * Management.Multigroup.multigroup) list) ~(init_mode : mode) = + object (self) + val mutable bh : Nt.branch_handle = init_bh + val name : string = init_name + val mutable tip : string = init_tip + val mutable mode : mode = init_mode + + val mgs : (string, Management.Multigroup.multigroup) Hashtbl.t = + let t = Hashtbl.create 8 in + List.iter (fun (n, mg) -> Hashtbl.replace t n mg) init_mgs; + t + + method name = name + method tip = tip + method snapshot = tip + method mode = mode + method branch_handle = bh + method mg_of (n : string) : Management.Multigroup.multigroup option = Hashtbl.find_opt mgs n + + method multigroups : (string * Management.Multigroup.multigroup) list = + Hashtbl.to_seq mgs |> List.of_seq + + (* Register a fresh mg under this branch. Idempotent. *) + method add_multigroup ~(name : string) : unit = + if not (Hashtbl.mem mgs name) then + Hashtbl.add mgs name (new Management.Multigroup.multigroup ~name) + + (* Replace the cached mg value (e.g. after an NT mutation returned a new mg). Idempotent insert if the mg was not present. *) - method set_mg ~(name : string) (mg : Management.Multigroup.multigroup) : unit = - Hashtbl.replace mgs name mg + method set_mg ~(name : string) (mg : Management.Multigroup.multigroup) : unit = + Hashtbl.replace mgs name mg - (* Path for a relation in this branch (Live) or its pinned snapshot + (* Path for a relation in this branch (Live) or its pinned snapshot (Detached). Pass [~branch] to reference a relation on a different live branch (cross-multigroup reads). *) - method path ?(branch : string option) (fqn : Qualified_name.t) : string = - match branch with - | Some b -> - "/system/branches/" ^ b ^ "/multigroups/" ^ fqn.mg - ^ "/relations/" ^ fqn.name - | None -> + method path ?(branch : string option) (fqn : Qualified_name.t) : string = + match branch with + | Some b -> "/system/branches/" ^ b ^ "/multigroups/" ^ fqn.mg ^ "/relations/" ^ fqn.name + | None -> ( match mode with - | Live -> - "/system/branches/" ^ name ^ "/multigroups/" ^ fqn.mg - ^ "/relations/" ^ fqn.name - | Detached hash -> - "/system/snapshots/" ^ hash ^ "/relations/" ^ fqn.name - - method private assert_live op = - match mode with - | Live -> Ok () - | Detached _ -> - Error (Error.not_supported (op ^ ": detached snapshot is read-only")) - - method private sync_tip () = - match mode with - | Detached _ -> () - | Live -> - match NT.branch_target_of_handle bh with - | Error _ -> () - | Ok h -> tip <- h - - method private get_mg op (mg_name : string) : - (Management.Multigroup.multigroup, Condition.t) result = - match Hashtbl.find_opt mgs mg_name with - | Some mg -> Ok mg - | None -> Error (Error.handle_error - (op ^ ": multigroup not found: " ^ mg_name)) - - method create_relation ~(mg : string) ~(rel_name : string) ~schema = - let* () = self#assert_live "create_relation" in - let* mg_val = self#get_mg "create_relation" mg in - let* (bh', mg') = - NT.create_relation bh mg_val - ~branch_name:name ~name:rel_name ~schema - in - bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () - - method retract_relation ~(mg : string) ~(rel_name : string) = - let* () = self#assert_live "retract_relation" in - let* mg_val = self#get_mg "retract_relation" mg in - let* (bh', mg') = NT.retract_relation bh mg_val ~name:rel_name in - bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () - - method clear_relation ~(mg : string) ~(rel_name : string) = - let* () = self#assert_live "clear_relation" in - let* mg_val = self#get_mg "clear_relation" mg in - match mg_val#get_relation rel_name with - | None -> Error (Error.handle_error ("relation not found: " ^ rel_name)) - | Some rel -> - let* (bh', mg') = - NT.clear_relation bh mg_val - ~branch_name:name ~mg_name:mg rel - in - bh <- bh'; Hashtbl.replace mgs mg mg'; self#sync_tip (); Ok () - - method register_domain ~(mg : string) domain = - let* () = self#assert_live "register_domain" in - let* mg_val = self#get_mg "register_domain" mg in - let* (bh', mg') = NT.register_domain bh mg_val domain in - bh <- bh'; Hashtbl.replace mgs mg mg'; Ok () - - method create_immutable_relation ~(mg : string) ~name:rel_name ~schema - ~generator ~membership_criteria ~cardinality ~producer = - let* () = self#assert_live "create_immutable_relation" in - let* mg_val = self#get_mg "create_immutable_relation" mg in - let* (bh', mg', rel) = - NT.create_immutable_relation bh mg_val ~name:rel_name ~schema ~generator - ~membership_criteria ~cardinality ~producer - in - bh <- bh'; Hashtbl.replace mgs mg mg'; Ok rel - - method register_constraint ~(mg : string) ~constraint_name ~relation_name - ~body = - let* () = self#assert_live "register_constraint" in - let* mg_val = self#get_mg "register_constraint" mg in - let* (bh', mg') = - NT.register_constraint bh mg_val ~constraint_name ~relation_name ~body - in - bh <- bh'; Hashtbl.replace mgs mg mg'; Ok () - - method insert_tuple ~(mg : string) ~(rel_name : string) attrs = - let* () = self#assert_live "insert_tuple" in - let* hash = - NT.insert_tuple ~branch_name:name ~mg_name:mg ~rel_name attrs - in - self#sync_tip (); Ok hash - - method create_tuple ~(mg : string) ~(rel_name : string) tuple = - let* () = self#assert_live "create_tuple" in - let* hash = - NT.create_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple - in - self#sync_tip (); Ok hash - - method create_tuples ~(mg : string) ~(rel_name : string) tuples = - let* () = self#assert_live "create_tuples" in - let* hash = - NT.create_tuples ~branch_name:name ~mg_name:mg ~rel_name tuples - in - self#sync_tip (); Ok hash - - method retract_tuple ~(mg : string) ~(rel_name : string) ~tuple_hash = - let* () = self#assert_live "retract_tuple" in - let* () = - NT.retract_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple_hash - in - self#sync_tip (); Ok () - - (* Applies a Transition delta from a sublanguage executor. Each entry + | Live -> "/system/branches/" ^ name ^ "/multigroups/" ^ fqn.mg ^ "/relations/" ^ fqn.name + | Detached hash -> "/system/snapshots/" ^ hash ^ "/relations/" ^ fqn.name ) + + method private assert_live op = + match mode with + | Live -> Ok () + | Detached _ -> Error (Error.not_supported (op ^ ": detached snapshot is read-only")) + + method private sync_tip () = + match mode with + | Detached _ -> () + | Live -> ( match NT.branch_target_of_handle bh with Error _ -> () | Ok h -> tip <- h ) + + method private get_mg op (mg_name : string) : + (Management.Multigroup.multigroup, Condition.t) result = + match Hashtbl.find_opt mgs mg_name with + | Some mg -> Ok mg + | None -> Error (Error.handle_error (op ^ ": multigroup not found: " ^ mg_name)) + + method create_relation ~(mg : string) ~(rel_name : string) ~schema = + let* () = self#assert_live "create_relation" in + let* mg_val = self#get_mg "create_relation" mg in + let* bh', mg' = NT.create_relation bh mg_val ~branch_name:name ~name:rel_name ~schema in + bh <- bh'; + Hashtbl.replace mgs mg mg'; + self#sync_tip (); + Ok () + + method retract_relation ~(mg : string) ~(rel_name : string) = + let* () = self#assert_live "retract_relation" in + let* mg_val = self#get_mg "retract_relation" mg in + let* bh', mg' = NT.retract_relation bh mg_val ~name:rel_name in + bh <- bh'; + Hashtbl.replace mgs mg mg'; + self#sync_tip (); + Ok () + + method clear_relation ~(mg : string) ~(rel_name : string) = + let* () = self#assert_live "clear_relation" in + let* mg_val = self#get_mg "clear_relation" mg in + match mg_val#get_relation rel_name with + | None -> Error (Error.handle_error ("relation not found: " ^ rel_name)) + | Some rel -> + let* bh', mg' = NT.clear_relation bh mg_val ~branch_name:name ~mg_name:mg rel in + bh <- bh'; + Hashtbl.replace mgs mg mg'; + self#sync_tip (); + Ok () + + method register_domain ~(mg : string) domain = + let* () = self#assert_live "register_domain" in + let* mg_val = self#get_mg "register_domain" mg in + let* bh', mg' = NT.register_domain bh mg_val domain in + bh <- bh'; + Hashtbl.replace mgs mg mg'; + Ok () + + method create_immutable_relation ~(mg : string) ~name:rel_name ~schema ~generator + ~membership_criteria ~cardinality ~producer = + let* () = self#assert_live "create_immutable_relation" in + let* mg_val = self#get_mg "create_immutable_relation" mg in + let* bh', mg', rel = + NT.create_immutable_relation bh mg_val ~name:rel_name ~schema ~generator + ~membership_criteria ~cardinality ~producer + in + bh <- bh'; + Hashtbl.replace mgs mg mg'; + Ok rel + + method register_constraint ~(mg : string) ~constraint_name ~relation_name ~body = + let* () = self#assert_live "register_constraint" in + let* mg_val = self#get_mg "register_constraint" mg in + let* bh', mg' = NT.register_constraint bh mg_val ~constraint_name ~relation_name ~body in + bh <- bh'; + Hashtbl.replace mgs mg mg'; + Ok () + + method insert_tuple ~(mg : string) ~(rel_name : string) attrs = + let* () = self#assert_live "insert_tuple" in + let* hash = NT.insert_tuple ~branch_name:name ~mg_name:mg ~rel_name attrs in + self#sync_tip (); Ok hash + + method create_tuple ~(mg : string) ~(rel_name : string) tuple = + let* () = self#assert_live "create_tuple" in + let* hash = NT.create_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple in + self#sync_tip (); Ok hash + + method create_tuples ~(mg : string) ~(rel_name : string) tuples = + let* () = self#assert_live "create_tuples" in + let* hash = NT.create_tuples ~branch_name:name ~mg_name:mg ~rel_name tuples in + self#sync_tip (); Ok hash + + method retract_tuple ~(mg : string) ~(rel_name : string) ~tuple_hash = + let* () = self#assert_live "retract_tuple" in + let* () = NT.retract_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple_hash in + self#sync_tip (); Ok () + + (* Applies a Transition delta from a sublanguage executor. Each entry replaces the named mg in the cache, then the tip is re-read. *) - method apply_delta (delta : (string * Management.Multigroup.multigroup) list) = - List.iter - (fun (mg_name, mg_val) -> Hashtbl.replace mgs mg_name mg_val) - delta; - self#sync_tip () + method apply_delta (delta : (string * Management.Multigroup.multigroup) list) = + List.iter (fun (mg_name, mg_val) -> Hashtbl.replace mgs mg_name mg_val) delta; + self#sync_tip () - method close () = NT.close_branch bh - end + method close () = NT.close_branch bh + end (* Default mg name seeded into an unborn branch so the session can write into something. Real catalog seeding (under "sakura") is the prelude's @@ -188,11 +170,8 @@ module Make (NT : Nt.S) = struct let default_mg_name = "public" let open_branch claims branch_name = - let* (bh, _legacy_mg) = NT.open_branch claims branch_name in - let tip = match NT.branch_target_of_handle bh with - | Ok h -> h - | Error _ -> "" - in + let* bh, _legacy_mg = NT.open_branch claims branch_name in + let tip = match NT.branch_target_of_handle bh with Ok h -> h | Error _ -> "" in let* mg_entries = NT.list_branch_multigroups branch_name in let mgs = List.map @@ -202,47 +181,39 @@ module Make (NT : Nt.S) = struct snapshot codec — they are repopulated by DDL replay / catalog reads later. *) let rels = - match NT.list_relations ~branch_name ~mg_name with - | Ok pairs -> pairs - | Error _ -> [] + match NT.list_relations ~branch_name ~mg_name with Ok pairs -> pairs | Error _ -> [] in let mg = List.fold_left (fun mg (rel_name, root) -> let rel = (new Relation.stored - ~name:rel_name - ~schema:[] - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:(Some (Relation.Lineage.Base rel_name)) - ~provenance:(Some (Relation.Provenance.base - ~relation:rel_name ~attributes:[])) - ~membership_criteria:(fun _ -> true)) - #set_tree_pointer (Some root) + ~name:rel_name ~schema:[] ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base rel_name)) + ~provenance:(Some (Relation.Provenance.base ~relation:rel_name ~attributes:[])) + ~membership_criteria:(fun _ -> true) ) + #set_tree_pointer + (Some root) in - mg#add_relation (rel :> Relation.relation)) + mg#add_relation (rel :> Relation.relation) ) (new Management.Multigroup.multigroup ~name:mg_name) rels in - (mg_name, mg)) + mg_name, mg ) mg_entries in let mgs = - if mgs = [] then - [ (default_mg_name, - new Management.Multigroup.multigroup ~name:default_mg_name) ] + if mgs = [] then [default_mg_name, new Management.Multigroup.multigroup ~name:default_mg_name] else mgs in - Ok (new branch - ~init_bh:bh ~init_name:branch_name ~init_tip:tip ~init_mgs:mgs - ~init_mode:Live) + Ok (new branch ~init_bh:bh ~init_name:branch_name ~init_tip:tip ~init_mgs:mgs ~init_mode:Live) let open_snapshot claims ~branch_name ~snapshot_hash = - let* (bh, mg) = NT.open_snapshot claims branch_name snapshot_hash in - Ok (new branch - ~init_bh:bh ~init_name:branch_name ~init_tip:snapshot_hash - ~init_mgs:[ (mg#name, mg) ] - ~init_mode:(Detached snapshot_hash)) - + let* bh, mg = NT.open_snapshot claims branch_name snapshot_hash in + Ok + (new branch + ~init_bh:bh ~init_name:branch_name ~init_tip:snapshot_hash + ~init_mgs:[mg#name, mg] + ~init_mode:(Detached snapshot_hash) ) end diff --git a/lib/condition.ml b/lib/condition.ml index 83ae9b8..c565b59 100644 --- a/lib/condition.ml +++ b/lib/condition.ml @@ -1,55 +1,56 @@ - class type serializable = object method as_sexp : Sexplib.Sexp.t method as_string : string end -class literal (expr : Sexplib.Sexp.t) : serializable = object - method as_sexp = expr - method as_string = Sexplib.Sexp.to_string_hum expr -end +class literal (expr : Sexplib.Sexp.t) : serializable = + object + method as_sexp = expr + method as_string = Sexplib.Sexp.to_string_hum expr + end let of_sexp (expr : Sexplib.Sexp.t) = new literal expr let of_string (s : string) = new literal (Sexplib.Sexp.Atom s) let of_int (n : int) = of_string (Int.to_string n) + let of_list (f : 'a -> serializable) (l : 'a list) : serializable = new literal (Sexplib.Sexp.List (List.map (fun e -> (f e)#as_sexp) l)) -type t = { name : string; - message : string; - backtrace : Printexc.raw_backtrace; - properties : (string, serializable) BatMap.t } +type t = + { name: string; + message: string; + backtrace: Printexc.raw_backtrace; + properties: (string, serializable) BatMap.t } let condition name message ?parent props = { name; message; - backtrace = Printexc.get_callstack 64; - properties = + backtrace= Printexc.get_callstack 64; + properties= parent - |> Option.map (fun { properties; _ } -> properties) + |> Option.map (fun {properties; _} -> properties) |> Option.value ~default:BatMap.empty |> props } -let ( |=| ) name value = (fun p -> BatMap.add name value p) -let ( & ) l r = (fun p -> r (l p)) -let empty = (fun p -> p) +let ( |=| ) name value = fun p -> BatMap.add name value p +let ( & ) l r = fun p -> r (l p) +let empty = fun p -> p -let to_sexp { name; message; properties; _ } = +let to_sexp {name; message; properties; _} = let open Sexplib.Sexp in let properties' = properties |> BatMap.to_seq |> BatSeq.map (fun (k, v) -> List [Atom k; v#as_sexp]) - |> BatList.of_seq in + |> BatList.of_seq + in List (Atom name :: Atom message :: properties') -let to_string { name; message; properties; backtrace } = +let to_string {name; message; properties; backtrace} = let properties' = properties |> BatMap.to_seq - |> BatSeq.to_string - ~first:"" ~last:"" ~sep:"\n" - (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string) + |> BatSeq.to_string ~first:"" ~last:"" ~sep:"\n" (fun (k, v) -> "\t" ^ k ^ ": " ^ v#as_string) in let backtrace' = Printexc.raw_backtrace_to_string backtrace in name ^ ": " ^ message ^ "\n" ^ properties' ^ "\n\nBacktrace:\n" ^ backtrace' diff --git a/lib/configuration.ml b/lib/configuration.ml index 12a3681..af1635f 100644 --- a/lib/configuration.ml +++ b/lib/configuration.ml @@ -6,34 +6,50 @@ end module Error = struct open Condition - let unknown_section key = condition "unknown-section" "Unknown configuration section" - ("key" |=| (of_string key)) - let duplicate_section key = condition "duplicate-section" "Duplicate configuration section" - ("key" |=| (of_string key)) - let empty_section key = condition "empty-section" "Empty configuration section (expected a tagged value)" - ("key" |=| (of_string key)) - let multiple_values_in_section key = condition "multiple-values-in-section" "Configuration section contains multiple values (expected exactly one)" - ("key" |=| (of_string key)) - let invalid_toplevel toplevel = condition "invalid-toplevel" "Configuration must be a (server ...) s-expression" - ("expression" |=| (of_sexp toplevel)) - let malformed_section expr = condition "malformed-section" "Section must be a (tag ...) s-expression" - ("expression" |=| (of_sexp expr)) - let missing_section name = condition "missing-section" "Missing section in configuration" - ("name" |=| (of_string name)) - let invalid_tag section tag valid_options = condition "invalid-tag" "Invalid tag for section" - ("section" |=| (of_string section) & - "tag" |=| (of_string tag) & - "valid-options" |=| (of_list of_string valid_options)) - let failed_to_load_file path msg = condition "failed-to-load-file" "Failed to load configuration file" - ("path" |=| (of_string path) & - "message" |=| (of_string msg)) - let syntax_error path msg = condition "syntax-error" "Failed to parse configuration file" - ("path" |=| (of_string path) & - "message" |=| (of_string msg)) + + let unknown_section key = + condition "unknown-section" "Unknown configuration section" ("key" |=| of_string key) + + let duplicate_section key = + condition "duplicate-section" "Duplicate configuration section" ("key" |=| of_string key) + + let empty_section key = + condition "empty-section" "Empty configuration section (expected a tagged value)" + ("key" |=| of_string key) + + let multiple_values_in_section key = + condition "multiple-values-in-section" + "Configuration section contains multiple values (expected exactly one)" + ("key" |=| of_string key) + + let invalid_toplevel toplevel = + condition "invalid-toplevel" "Configuration must be a (server ...) s-expression" + ("expression" |=| of_sexp toplevel) + + let malformed_section expr = + condition "malformed-section" "Section must be a (tag ...) s-expression" + ("expression" |=| of_sexp expr) + + let missing_section name = + condition "missing-section" "Missing section in configuration" ("name" |=| of_string name) + + let invalid_tag section tag valid_options = + condition "invalid-tag" "Invalid tag for section" + ( "section" |=| of_string section + & "tag" |=| of_string tag + & "valid-options" |=| of_list of_string valid_options ) + + let failed_to_load_file path msg = + condition "failed-to-load-file" "Failed to load configuration file" + ("path" |=| of_string path & "message" |=| of_string msg) + + let syntax_error path msg = + condition "syntax-error" "Failed to parse configuration file" + ("path" |=| of_string path & "message" |=| of_string msg) end -type t = Sexplib.Sexp.t Utilities.StringMap.t (** Section name -> raw sexp subtree. *) +type t = Sexplib.Sexp.t Utilities.StringMap.t let find_section (key : string) (config : t) : Sexplib.Sexp.t option = Utilities.StringMap.find_opt key config @@ -42,20 +58,15 @@ let find_section (key : string) (config : t) : Sexplib.Sexp.t option = let insert_section ~expected acc key body = let ( let* ) = Result.bind in let* () = - if Utilities.StringSet.mem key expected then Ok () - else Error (Error.unknown_section key) + if Utilities.StringSet.mem key expected then Ok () else Error (Error.unknown_section key) in let* () = - if Utilities.StringMap.mem key acc then - Error (Error.duplicate_section key) - else Ok () + if Utilities.StringMap.mem key acc then Error (Error.duplicate_section key) else Ok () in match body with - | [ subtree ] -> Ok (Utilities.StringMap.add key subtree acc) - | [] -> - Error (Error.empty_section key) - | _ -> - Error (Error.multiple_values_in_section key) + | [subtree] -> Ok (Utilities.StringMap.add key subtree acc) + | [] -> Error (Error.empty_section key) + | _ -> Error (Error.multiple_values_in_section key) (** [(server ...)] sexp -> section map. Rejects unknown/duplicate keys. *) let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) result = @@ -63,16 +74,13 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) resul match sexp with | List (Atom "server" :: sections) -> let expected = - List.fold_right Utilities.StringSet.add expected_keys - Utilities.StringSet.empty + List.fold_right Utilities.StringSet.add expected_keys Utilities.StringSet.empty in let rec go acc = function | [] -> Ok acc | List (Atom key :: body) :: rest -> - Result.bind (insert_section ~expected acc key body) (fun acc -> - go acc rest) - | bad :: _ -> - Error (Error.malformed_section bad) + Result.bind (insert_section ~expected acc key body) (fun acc -> go acc rest) + | bad :: _ -> Error (Error.malformed_section bad) in go Utilities.StringMap.empty sections | _ -> Error (Error.invalid_toplevel sexp) @@ -81,14 +89,11 @@ let parse_server ~expected_keys (sexp : Sexplib.Sexp.t) : (t, Condition.t) resul let load ~expected_keys (path : string) : (t, Condition.t) result = match Sexplib.Sexp.load_sexp path with | sexp -> parse_server ~expected_keys sexp - | exception Sys_error msg -> - Error (Error.failed_to_load_file path msg) - | exception Failure msg -> - Error (Error.syntax_error path msg) + | exception Sys_error msg -> Error (Error.failed_to_load_file path msg) + | exception Failure msg -> Error (Error.syntax_error path msg) (** [(tag field1 ...)] -> [(tag, List [field1; ...])]. *) -let extract_tagged_section (sexp : Sexplib.Sexp.t) : - (string * Sexplib.Sexp.t, Condition.t) result = +let extract_tagged_section (sexp : Sexplib.Sexp.t) : (string * Sexplib.Sexp.t, Condition.t) result = let open Sexplib.Sexp in match sexp with | List (Atom tag :: body) -> Ok (tag, List body) @@ -98,10 +103,7 @@ let extract_tagged_section (sexp : Sexplib.Sexp.t) : let require_section ~(name : string) ~(valid_tags : string list) (config : t) : (string * Sexplib.Sexp.t, Condition.t) result = let ( let* ) = Result.bind in - let* sexp = - find_section name config - |> Option.to_result ~none:(Error.missing_section name) - in + let* sexp = find_section name config |> Option.to_result ~none:(Error.missing_section name) in let* tag, body = extract_tagged_section sexp in let* () = if List.mem tag valid_tags then Ok () else Error (Error.invalid_tag name tag valid_tags) diff --git a/lib/constraint.ml b/lib/constraint.ml index 5e282c2..f657b00 100644 --- a/lib/constraint.ml +++ b/lib/constraint.ml @@ -24,45 +24,42 @@ module FingerTree = BatFingerTree type binding = binding_expr BindingMap.t type t = - | MemberOf of { target : relation_name; binding : binding } - | Not of { body : t; universe : relation_name } + | MemberOf of {target: relation_name; binding: binding} + | Not of {body: t; universe: relation_name} | And of t list | Or of t list - | Exists of { variable : attr_name; quantifier : relation_name; body : t } - | Forall of { variable : attr_name; quantifier : relation_name; body : t } - | Eq of { left : binding_expr; right : binding_expr } + | Exists of {variable: attr_name; quantifier: relation_name; body: t} + | Forall of {variable: attr_name; quantifier: relation_name; body: t} + | Eq of {left: binding_expr; right: binding_expr} type diagnostic = - | MembershipFailed of { - target : string; - bound_values : (attr_name * Conventions.AbstractValue.t) list; - } + | MembershipFailed of + {target: string; bound_values: (attr_name * Conventions.AbstractValue.t) list} | RelationNotFound of string - | UnboundedQuantifier of { variable : attr_name; quantifier : relation_name } + | UnboundedQuantifier of {variable: attr_name; quantifier: relation_name} | ConstraintFailures of (string * diagnostic) list let vars_in (c : t) : attr_name list = let add_from_binding set binding = BindingMap.fold - (fun _ expr acc -> - match expr with Var v -> StringSet.add v acc | Const _ -> acc) + (fun _ expr acc -> match expr with Var v -> StringSet.add v acc | Const _ -> acc) binding set in let rec loop set worklist = match FingerTree.front worklist with | None -> set | Some (rest, node) -> ( - match node with - | MemberOf { binding; _ } -> loop (add_from_binding set binding) rest - | Not { body; _ } -> loop set (FingerTree.cons rest body) - | And cs | Or cs -> - let next = FingerTree.append (FingerTree.of_list cs) rest in - loop set next - | Exists { variable; body; _ } | Forall { variable; body; _ } -> - loop (StringSet.add variable set) (FingerTree.cons rest body) - | Eq { left; right } -> - let add_expr acc = function Var v -> StringSet.add v acc | Const _ -> acc in - loop (add_expr (add_expr set left) right) rest) + match node with + | MemberOf {binding; _} -> loop (add_from_binding set binding) rest + | Not {body; _} -> loop set (FingerTree.cons rest body) + | And cs | Or cs -> + let next = FingerTree.append (FingerTree.of_list cs) rest in + loop set next + | Exists {variable; body; _} | Forall {variable; body; _} -> + loop (StringSet.add variable set) (FingerTree.cons rest body) + | Eq {left; right} -> + let add_expr acc = function Var v -> StringSet.add v acc | Const _ -> acc in + loop (add_expr (add_expr set left) right) rest ) in loop StringSet.empty (FingerTree.singleton c) |> StringSet.elements @@ -72,30 +69,28 @@ let rename_vars (renames : (attr_name * attr_name) list) : t -> t = match BindingMap.find_opt name rename_map with Some n -> n | None -> name in let rec go = function - | MemberOf { target; binding } -> + | MemberOf {target; binding} -> let binding' = BindingMap.fold (fun k expr acc -> let k' = rename_name k in - let expr' = - match expr with Var v -> Var (rename_name v) | Const _ -> expr - in - BindingMap.add k' expr' acc) + let expr' = match expr with Var v -> Var (rename_name v) | Const _ -> expr in + BindingMap.add k' expr' acc ) binding BindingMap.empty in - MemberOf { target; binding = binding' } - | Not { body; universe } -> Not { body = go body; universe } + MemberOf {target; binding= binding'} + | Not {body; universe} -> Not {body= go body; universe} | And cs -> And (List.map go cs) | Or cs -> Or (List.map go cs) - | Exists { variable; quantifier; body } -> + | Exists {variable; quantifier; body} -> let variable' = rename_name variable in - Exists { variable = variable'; quantifier; body = go body } - | Forall { variable; quantifier; body } -> + Exists {variable= variable'; quantifier; body= go body} + | Forall {variable; quantifier; body} -> let variable' = rename_name variable in - Forall { variable = variable'; quantifier; body = go body } - | Eq { left; right } -> + Forall {variable= variable'; quantifier; body= go body} + | Eq {left; right} -> let rename_expr = function Var v -> Var (rename_name v) | Const _ as e -> e in - Eq { left = rename_expr left; right = rename_expr right } + Eq {left= rename_expr left; right= rename_expr right} in go @@ -105,10 +100,10 @@ let rec filter_by_attrs (attrs : attr_name list) (c : t) : t option = let all_present c = List.for_all (fun v -> List.mem v attrs) (vars_in c) in match c with | MemberOf _ -> if all_present c then Some c else None - | Not { body; universe } -> ( - match filter_by_attrs attrs body with - | Some body' -> Some (Not { body = body'; universe }) - | None -> None) + | Not {body; universe} -> ( + match filter_by_attrs attrs body with + | Some body' -> Some (Not {body= body'; universe}) + | None -> None ) | And cs -> let kept = List.filter_map (filter_by_attrs attrs) cs in if kept = [] then None else Some (And kept) @@ -116,139 +111,132 @@ let rec filter_by_attrs (attrs : attr_name list) (c : t) : t option = (* All branches must survive for Or to remain sound *) let kept = List.filter_map (filter_by_attrs attrs) cs in if List.length kept = List.length cs then Some (Or kept) else None - | Exists { variable; quantifier; body } -> ( - match filter_by_attrs (variable :: attrs) body with - | Some body' -> Some (Exists { variable; quantifier; body = body' }) - | None -> None) - | Forall { variable; quantifier; body } -> ( - match filter_by_attrs (variable :: attrs) body with - | Some body' -> Some (Forall { variable; quantifier; body = body' }) - | None -> None) + | Exists {variable; quantifier; body} -> ( + match filter_by_attrs (variable :: attrs) body with + | Some body' -> Some (Exists {variable; quantifier; body= body'}) + | None -> None ) + | Forall {variable; quantifier; body} -> ( + match filter_by_attrs (variable :: attrs) body with + | Some body' -> Some (Forall {variable; quantifier; body= body'}) + | None -> None ) | Eq _ -> if all_present c then Some c else None -let merge (cs1 : (string * t) list) (cs2 : (string * t) list) : - (string * t) list = +let merge (cs1 : (string * t) list) (cs2 : (string * t) list) : (string * t) list = let combined = cs1 @ cs2 in let tbl = Hashtbl.create 16 in List.iter (fun (name, c) -> match Hashtbl.find_opt tbl name with - | None -> Hashtbl.replace tbl name [ c ] - | Some cs -> Hashtbl.replace tbl name (c :: cs)) + | None -> Hashtbl.replace tbl name [c] + | Some cs -> Hashtbl.replace tbl name (c :: cs) ) combined; Hashtbl.fold (fun name cs acc -> - let merged = match cs with [ c ] -> c | _ -> And cs in - (name, merged) :: acc) + let merged = match cs with [c] -> c | _ -> And cs in + (name, merged) :: acc ) tbl [] -let member_of ~target ~binding = MemberOf { target; binding } -let not_ ~universe body = Not { body; universe } -let and_ cs = match cs with [ c ] -> c | _ -> And cs -let or_ cs = match cs with [ c ] -> c | _ -> Or cs -let exists ~variable ~quantifier body = Exists { variable; quantifier; body } -let forall ~variable ~quantifier body = Forall { variable; quantifier; body } - -type eval_context = { - check_membership : - relation_name -> (attr_name * Conventions.AbstractValue.t) list -> bool; - iterate_finite : - relation_name -> (attr_name * Conventions.AbstractValue.t) list list option; -} - -let bind (b : binding) (tuple : Tuple.materialized) : - (attr_name * Conventions.AbstractValue.t) list = +let member_of ~target ~binding = MemberOf {target; binding} +let not_ ~universe body = Not {body; universe} +let and_ cs = match cs with [c] -> c | _ -> And cs +let or_ cs = match cs with [c] -> c | _ -> Or cs +let exists ~variable ~quantifier body = Exists {variable; quantifier; body} +let forall ~variable ~quantifier body = Forall {variable; quantifier; body} + +type eval_context = + { check_membership: relation_name -> (attr_name * Conventions.AbstractValue.t) list -> bool; + iterate_finite: relation_name -> (attr_name * Conventions.AbstractValue.t) list list option } + +let bind (b : binding) (tuple : Tuple.materialized) : (attr_name * Conventions.AbstractValue.t) list + = BindingMap.fold (fun target_attr expr acc -> let value = match expr with | Const v -> Some v | Var src_attr -> ( - match Tuple.AttributeMap.find_opt src_attr tuple.attributes with - | Some attr -> Some attr.Attribute.value - | None -> None) + match Tuple.AttributeMap.find_opt src_attr tuple.attributes with + | Some attr -> Some attr.Attribute.value + | None -> None ) in - match value with Some v -> (target_attr, v) :: acc | None -> acc) + match value with Some v -> (target_attr, v) :: acc | None -> acc ) b [] let rec evaluate (ctx : eval_context) (tuple : Tuple.materialized) (c : t) : (bool, diagnostic) result = match c with - | MemberOf { target; binding } -> + | MemberOf {target; binding} -> let bound_values = bind binding tuple in if ctx.check_membership target bound_values then Ok true - else Error (MembershipFailed { target; bound_values }) - | Not { body; universe = _ } -> ( - (* The universe is a declarative annotation for closed-world reasoning. + else Error (MembershipFailed {target; bound_values}) + | Not {body; universe= _} -> ( + (* The universe is a declarative annotation for closed-world reasoning. At runtime we negate the body; the universe enforces logical soundness at the schema level, not as a runtime tuple-existence check. *) - match evaluate ctx tuple body with - | Ok true -> Ok false - | Ok false -> Ok true - | Error (MembershipFailed _) -> Ok true - | Error d -> Error d) + match evaluate ctx tuple body with + | Ok true -> Ok false + | Ok false -> Ok true + | Error (MembershipFailed _) -> Ok true + | Error d -> Error d ) | And cs -> evaluate_and ctx tuple cs | Or cs -> evaluate_or ctx tuple cs - | Eq { left; right } -> + | Eq {left; right} -> ( let resolve = function | Const v -> Some v | Var a -> ( - match Tuple.AttributeMap.find_opt a tuple.attributes with - | Some attr -> Some attr.Attribute.value - | None -> None) + match Tuple.AttributeMap.find_opt a tuple.attributes with + | Some attr -> Some attr.Attribute.value + | None -> None ) in - (match (resolve left, resolve right) with - | Some l, Some r -> Ok (l = r) - | _ -> Ok false) - | Exists { variable; quantifier; body } -> ( - match ctx.iterate_finite quantifier with - | None -> Error (UnboundedQuantifier { variable; quantifier }) - | Some rows -> - let rec check = function - | [] -> Ok false - | row :: rest -> ( - let extended_tuple = extend_tuple tuple variable row in - match evaluate ctx extended_tuple body with - | Ok true -> Ok true - | Ok false -> check rest - | Error _ -> check rest) - in - check rows) - | Forall { variable; quantifier; body } -> ( - match ctx.iterate_finite quantifier with - | None -> Error (UnboundedQuantifier { variable; quantifier }) - | Some rows -> - let rec check = function - | [] -> Ok true - | row :: rest -> ( - let extended_tuple = extend_tuple tuple variable row in - match evaluate ctx extended_tuple body with - | Ok true -> check rest - | Ok false -> Ok false - | Error (MembershipFailed _) -> Ok false - | Error d -> Error d) - in - check rows) + match resolve left, resolve right with Some l, Some r -> Ok (l = r) | _ -> Ok false ) + | Exists {variable; quantifier; body} -> ( + match ctx.iterate_finite quantifier with + | None -> Error (UnboundedQuantifier {variable; quantifier}) + | Some rows -> + let rec check = function + | [] -> Ok false + | row :: rest -> ( + let extended_tuple = extend_tuple tuple variable row in + match evaluate ctx extended_tuple body with + | Ok true -> Ok true + | Ok false -> check rest + | Error _ -> check rest ) + in + check rows ) + | Forall {variable; quantifier; body} -> ( + match ctx.iterate_finite quantifier with + | None -> Error (UnboundedQuantifier {variable; quantifier}) + | Some rows -> + let rec check = function + | [] -> Ok true + | row :: rest -> ( + let extended_tuple = extend_tuple tuple variable row in + match evaluate ctx extended_tuple body with + | Ok true -> check rest + | Ok false -> Ok false + | Error (MembershipFailed _) -> Ok false + | Error d -> Error d ) + in + check rows ) and evaluate_and ctx tuple = function | [] -> Ok true | c :: rest -> ( - match evaluate ctx tuple c with - | Ok true -> evaluate_and ctx tuple rest - | Ok false -> Ok false - | Error d -> Error d) + match evaluate ctx tuple c with + | Ok true -> evaluate_and ctx tuple rest + | Ok false -> Ok false + | Error d -> Error d ) and evaluate_or ctx tuple = function | [] -> Ok false | c :: rest -> ( - match evaluate ctx tuple c with - | Ok true -> Ok true - | Ok false -> evaluate_or ctx tuple rest - | Error _ -> evaluate_or ctx tuple rest) + match evaluate ctx tuple c with + | Ok true -> Ok true + | Ok false -> evaluate_or ctx tuple rest + | Error _ -> evaluate_or ctx tuple rest ) and extend_tuple (tuple : Tuple.materialized) (variable : attr_name) - (row : (attr_name * Conventions.AbstractValue.t) list) : Tuple.materialized - = + (row : (attr_name * Conventions.AbstractValue.t) list) : Tuple.materialized = (* Quantifier attributes are namespaced by the variable name (for example "d.dept_id") so they cannot silently overwrite same-named attributes from the base tuple or from other quantifiers. Without such namespacing, a constraint like @@ -263,23 +251,21 @@ and extend_tuple (tuple : Tuple.materialized) (variable : attr_name) to each attribute rather than relying on name conventions, but we don't have that yet. *) let extra_attrs = List.fold_left - (fun acc (k, v) -> - Tuple.AttributeMap.add (variable ^ "." ^ k) { Attribute.value = v } acc) + (fun acc (k, v) -> Tuple.AttributeMap.add (variable ^ "." ^ k) {Attribute.value= v} acc) tuple.attributes row in - { tuple with attributes = extra_attrs } + {tuple with attributes= extra_attrs} (* TODO: Sometimes it's more efficient and sufficient to simply halt at the first constraint violated. However, it's also important to be able to adjudicate which constraints failed on the tuple materialization. For that reason, we should likely return a lazy stream that computes the constraints on demand. *) -let evaluate_named (ctx : eval_context) (tuple : Tuple.materialized) - (named : (string * t) list) : (bool, diagnostic) result = +let evaluate_named (ctx : eval_context) (tuple : Tuple.materialized) (named : (string * t) list) : + (bool, diagnostic) result = let failures = List.filter_map (fun (name, c) -> match evaluate ctx tuple c with | Ok true -> None - | Ok false -> - Some (name, MembershipFailed { target = name; bound_values = [] }) - | Error d -> Some (name, d)) + | Ok false -> Some (name, MembershipFailed {target= name; bound_values= []}) + | Error d -> Some (name, d) ) named in match failures with [] -> Ok true | fs -> Error (ConstraintFailures fs) @@ -290,8 +276,7 @@ let evaluate_first_failure (ctx : eval_context) (tuple : Tuple.materialized) (named : (string * t) list) : (bool, diagnostic) result = let rec loop = function | [] -> Ok true - | (_name, c) :: rest -> ( - match evaluate ctx tuple c with Ok true -> loop rest | r -> r) + | (_name, c) :: rest -> ( match evaluate ctx tuple c with Ok true -> loop rest | r -> r ) in loop named @@ -304,15 +289,9 @@ type polarity = Positive | Negative | Both type polarity_index = polarity PolarityMap.t let merge_polarity a b = - match (a, b) with - | Positive, Positive -> Positive - | Negative, Negative -> Negative - | _ -> Both + match a, b with Positive, Positive -> Positive | Negative, Negative -> Negative | _ -> Both -let flip_polarity = function - | Positive -> Negative - | Negative -> Positive - | Both -> Both +let flip_polarity = function Positive -> Negative | Negative -> Positive | Both -> Both let polarity_of ?(neg = false) (c : t) : polarity_index = let with_neg is_neg pol = if is_neg then flip_polarity pol else pol in @@ -325,23 +304,20 @@ let polarity_of ?(neg = false) (c : t) : polarity_index = match FingerTree.front worklist with | None -> acc | Some (rest, (is_neg, node)) -> ( - match node with - | MemberOf { target; _ } -> - loop (add_pol acc target (with_neg is_neg Positive)) rest - | Not { body; _ } -> loop acc (FingerTree.cons rest (not is_neg, body)) - | And cs | Or cs -> - let children = - List.map (fun child -> (is_neg, child)) cs |> FingerTree.of_list - in - let next = FingerTree.append children rest in - loop acc next - | Exists { quantifier; body; _ } -> - let acc' = add_pol acc quantifier (with_neg is_neg Positive) in - loop acc' (FingerTree.cons rest (is_neg, body)) - | Forall { quantifier; body; _ } -> - let acc' = add_pol acc quantifier (with_neg is_neg Negative) in - loop acc' (FingerTree.cons rest (is_neg, body)) - | Eq _ -> loop acc rest) + match node with + | MemberOf {target; _} -> loop (add_pol acc target (with_neg is_neg Positive)) rest + | Not {body; _} -> loop acc (FingerTree.cons rest (not is_neg, body)) + | And cs | Or cs -> + let children = List.map (fun child -> is_neg, child) cs |> FingerTree.of_list in + let next = FingerTree.append children rest in + loop acc next + | Exists {quantifier; body; _} -> + let acc' = add_pol acc quantifier (with_neg is_neg Positive) in + loop acc' (FingerTree.cons rest (is_neg, body)) + | Forall {quantifier; body; _} -> + let acc' = add_pol acc quantifier (with_neg is_neg Negative) in + loop acc' (FingerTree.cons rest (is_neg, body)) + | Eq _ -> loop acc rest ) in loop PolarityMap.empty (FingerTree.singleton (neg, c)) @@ -351,9 +327,7 @@ let polarity_find name (pols : polarity_index) = PolarityMap.find_opt name pols (checked at transaction commit). *) type timing = Immediate | Deferred -type substitute_mode = - | SubstituteGo - | SubstituteApply of Conventions.AbstractValue.t BindingMap.t +type substitute_mode = SubstituteGo | SubstituteApply of Conventions.AbstractValue.t BindingMap.t type substitute_instr = | Visit of substitute_mode * t @@ -380,26 +354,22 @@ let focused_filter (c : t) (dep_rel : relation_name) (fun _target_attr expr acc -> match expr with | Var src_attr -> ( - match List.assoc_opt src_attr deleted with - | Some v -> (src_attr, v) :: acc - | None -> acc) - | Const _ -> acc) + match List.assoc_opt src_attr deleted with Some v -> (src_attr, v) :: acc | None -> acc ) + | Const _ -> acc ) binding acc in let rec loop acc worklist = match FingerTree.front worklist with | None -> acc | Some (rest, node) -> ( - match node with - | MemberOf { target; binding } when target = dep_rel -> - loop (add_from_binding acc binding) rest - | MemberOf _ -> loop acc rest - | Not { body; _ } | Exists { body; _ } | Forall { body; _ } -> - loop acc (FingerTree.cons rest body) - | And cs | Or cs -> - let next = FingerTree.append (FingerTree.of_list cs) rest in - loop acc next - | Eq _ -> loop acc rest) + match node with + | MemberOf {target; binding} when target = dep_rel -> loop (add_from_binding acc binding) rest + | MemberOf _ -> loop acc rest + | Not {body; _} | Exists {body; _} | Forall {body; _} -> loop acc (FingerTree.cons rest body) + | And cs | Or cs -> + let next = FingerTree.append (FingerTree.of_list cs) rest in + loop acc next + | Eq _ -> loop acc rest ) in loop [] (FingerTree.singleton c) @@ -413,23 +383,21 @@ let trigger_constants (c : t) (dep_rel : relation_name) : let add_from_binding acc binding = BindingMap.fold (fun target_attr expr acc -> - match expr with Const v -> (target_attr, v) :: acc | Var _ -> acc) + match expr with Const v -> (target_attr, v) :: acc | Var _ -> acc ) binding acc in let rec loop acc worklist = match FingerTree.front worklist with | None -> acc | Some (rest, node) -> ( - match node with - | MemberOf { target; binding } when target = dep_rel -> - loop (add_from_binding acc binding) rest - | MemberOf _ -> loop acc rest - | Not { body; _ } | Exists { body; _ } | Forall { body; _ } -> - loop acc (FingerTree.cons rest body) - | And cs | Or cs -> - let next = FingerTree.append (FingerTree.of_list cs) rest in - loop acc next - | Eq _ -> loop acc rest) + match node with + | MemberOf {target; binding} when target = dep_rel -> loop (add_from_binding acc binding) rest + | MemberOf _ -> loop acc rest + | Not {body; _} | Exists {body; _} | Forall {body; _} -> loop acc (FingerTree.cons rest body) + | And cs | Or cs -> + let next = FingerTree.append (FingerTree.of_list cs) rest in + loop acc next + | Eq _ -> loop acc rest ) in loop [] (FingerTree.singleton c) @@ -460,8 +428,7 @@ let substitute_transition (c : t) (dep_rel : relation_name) let enqueue_children mode cs build_of_count rest = let prefix, count = List.fold_left - (fun (acc, n) child -> - (FingerTree.snoc acc (Visit (mode, child)), n + 1)) + (fun (acc, n) child -> FingerTree.snoc acc (Visit (mode, child)), n + 1) (FingerTree.empty, 0) cs in let prefix = FingerTree.snoc prefix (build_of_count count) in @@ -471,182 +438,142 @@ let substitute_transition (c : t) (dep_rel : relation_name) BindingMap.map (function | Var v -> ( - match BindingMap.find_opt v subs with - | Some value -> Const value - | None -> Var v) - | Const _ as expr -> expr) + match BindingMap.find_opt v subs with Some value -> Const value | None -> Var v ) + | Const _ as expr -> expr ) binding in let rec pop_n n vals acc = - if n = 0 then (acc, vals) - else - match vals with - | [] -> (acc, []) - | v :: rest -> pop_n (n - 1) rest (v :: acc) + if n = 0 then acc, vals + else match vals with [] -> acc, [] | v :: rest -> pop_n (n - 1) rest (v :: acc) in let rec loop instrs vals = match FingerTree.front instrs with - | None -> ( match vals with [ result ] -> result | _ -> c) + | None -> ( match vals with [result] -> result | _ -> c ) | Some (rest, instr) -> ( - match instr with - | Visit (mode, node) -> ( - match node with - | MemberOf { target; binding } -> - let binding' = - match mode with - | SubstituteGo -> binding - | SubstituteApply subs -> apply_subs subs binding - in - loop rest (MemberOf { target; binding = binding' } :: vals) - | Not { body; universe } -> - loop - (enqueue_visit_then_build - (Visit (mode, body)) - (BuildNot universe) rest) - vals - | And cs -> - let instrs' = - enqueue_children mode cs (fun n -> BuildAnd n) rest - in - loop instrs' vals - | Or cs -> - let instrs' = - enqueue_children mode cs (fun n -> BuildOr n) rest - in - loop instrs' vals - | Exists { variable; quantifier; body } -> - let body_mode = - match mode with - | SubstituteApply subs -> SubstituteApply subs - | SubstituteGo -> - if quantifier = dep_rel then - SubstituteApply (namespaced_subs variable) - else SubstituteGo - in - loop - (enqueue_visit_then_build - (Visit (body_mode, body)) - (BuildExists (variable, quantifier)) - rest) - vals - | Forall { variable; quantifier; body } -> - let body_mode = - match mode with - | SubstituteApply subs -> SubstituteApply subs - | SubstituteGo -> - if quantifier = dep_rel then - SubstituteApply (namespaced_subs variable) - else SubstituteGo - in - loop - (enqueue_visit_then_build - (Visit (body_mode, body)) - (BuildForall (variable, quantifier)) - rest) - vals - | Eq { left; right } -> - let subst_expr subs = function - | Var v -> (match BindingMap.find_opt v subs with Some v' -> Const v' | None -> Var v) - | Const _ as e -> e - in - let left', right' = match mode with - | SubstituteGo -> (left, right) - | SubstituteApply subs -> (subst_expr subs left, subst_expr subs right) - in - loop rest (Eq { left = left'; right = right' } :: vals)) - | BuildNot universe -> ( - match vals with - | body :: vals' -> loop rest (Not { body; universe } :: vals') - | [] -> loop rest vals) - | BuildAnd n -> - let children, vals' = pop_n n vals [] in - loop rest (And children :: vals') - | BuildOr n -> - let children, vals' = pop_n n vals [] in - loop rest (Or children :: vals') - | BuildExists (variable, quantifier) -> ( - match vals with - | body :: vals' -> - loop rest (Exists { variable; quantifier; body } :: vals') - | [] -> loop rest vals) - | BuildForall (variable, quantifier) -> ( - match vals with - | body :: vals' -> - loop rest (Forall { variable; quantifier; body } :: vals') - | [] -> loop rest vals)) + match instr with + | Visit (mode, node) -> ( + match node with + | MemberOf {target; binding} -> + let binding' = + match mode with + | SubstituteGo -> binding + | SubstituteApply subs -> apply_subs subs binding + in + loop rest (MemberOf {target; binding= binding'} :: vals) + | Not {body; universe} -> + loop (enqueue_visit_then_build (Visit (mode, body)) (BuildNot universe) rest) vals + | And cs -> + let instrs' = enqueue_children mode cs (fun n -> BuildAnd n) rest in + loop instrs' vals + | Or cs -> + let instrs' = enqueue_children mode cs (fun n -> BuildOr n) rest in + loop instrs' vals + | Exists {variable; quantifier; body} -> + let body_mode = + match mode with + | SubstituteApply subs -> SubstituteApply subs + | SubstituteGo -> + if quantifier = dep_rel then SubstituteApply (namespaced_subs variable) + else SubstituteGo + in + loop + (enqueue_visit_then_build + (Visit (body_mode, body)) + (BuildExists (variable, quantifier)) + rest ) + vals + | Forall {variable; quantifier; body} -> + let body_mode = + match mode with + | SubstituteApply subs -> SubstituteApply subs + | SubstituteGo -> + if quantifier = dep_rel then SubstituteApply (namespaced_subs variable) + else SubstituteGo + in + loop + (enqueue_visit_then_build + (Visit (body_mode, body)) + (BuildForall (variable, quantifier)) + rest ) + vals + | Eq {left; right} -> + let subst_expr subs = function + | Var v -> ( + match BindingMap.find_opt v subs with Some v' -> Const v' | None -> Var v ) + | Const _ as e -> e + in + let left', right' = + match mode with + | SubstituteGo -> left, right + | SubstituteApply subs -> subst_expr subs left, subst_expr subs right + in + loop rest (Eq {left= left'; right= right'} :: vals) ) + | BuildNot universe -> ( + match vals with + | body :: vals' -> loop rest (Not {body; universe} :: vals') + | [] -> loop rest vals ) + | BuildAnd n -> + let children, vals' = pop_n n vals [] in + loop rest (And children :: vals') + | BuildOr n -> + let children, vals' = pop_n n vals [] in + loop rest (Or children :: vals') + | BuildExists (variable, quantifier) -> ( + match vals with + | body :: vals' -> loop rest (Exists {variable; quantifier; body} :: vals') + | [] -> loop rest vals ) + | BuildForall (variable, quantifier) -> ( + match vals with + | body :: vals' -> loop rest (Forall {variable; quantifier; body} :: vals') + | [] -> loop rest vals ) ) in loop (FingerTree.singleton (Visit (SubstituteGo, c))) [] let make_comparison_binding ~left ~right = BindingMap.empty |> BindingMap.add "left" left |> BindingMap.add "right" right -let lt ~left ~right = - MemberOf - { target = "less_than"; binding = make_comparison_binding ~left ~right } +let lt ~left ~right = MemberOf {target= "less_than"; binding= make_comparison_binding ~left ~right} let lte ~left ~right = - MemberOf - { - target = "less_than_or_equal"; - binding = make_comparison_binding ~left ~right; - } + MemberOf {target= "less_than_or_equal"; binding= make_comparison_binding ~left ~right} let gt ~left ~right = - MemberOf - { target = "greater_than"; binding = make_comparison_binding ~left ~right } + MemberOf {target= "greater_than"; binding= make_comparison_binding ~left ~right} let gte ~left ~right = - MemberOf - { - target = "greater_than_or_equal"; - binding = make_comparison_binding ~left ~right; - } - -let eq ~left ~right = Eq { left; right } + MemberOf {target= "greater_than_or_equal"; binding= make_comparison_binding ~left ~right} -let neq ~left ~right = - Not { body = Eq { left; right }; universe = "" } +let eq ~left ~right = Eq {left; right} +let neq ~left ~right = Not {body= Eq {left; right}; universe= ""} let between ~value ~low ~high = And - [ + [ MemberOf + {target= "greater_than_or_equal"; binding= make_comparison_binding ~left:value ~right:low}; MemberOf - { - target = "greater_than_or_equal"; - binding = make_comparison_binding ~left:value ~right:low; - }; - MemberOf - { - target = "less_than_or_equal"; - binding = make_comparison_binding ~left:value ~right:high; - }; - ] + {target= "less_than_or_equal"; binding= make_comparison_binding ~left:value ~right:high} ] (** Build membership criteria from schema (validates type membership). Returns a function that takes a tree-lookup function and a tuple, checking schema conformance and tree membership at call time. *) -let build_membership_criteria - ~_name - ~schema : - (*(string -> Merkle.t option) ->*) Tuple.t -> bool = - let value_conforms_to_domain domain_name (value : Conventions.AbstractValue.t) - = +let build_membership_criteria ~_name ~schema : (*(string -> Merkle.t option) ->*) Tuple.t -> bool = + let value_conforms_to_domain domain_name (value : Conventions.AbstractValue.t) = match domain_name with | "integer" -> Obj.is_int value | "natural" -> Obj.is_int value && (Obj.obj value : int) >= 0 | "string" -> Obj.tag value = Obj.string_tag | _ -> - (* Unknown domain: could be a relation-typed attribute (nested tuple) + (* Unknown domain: could be a relation-typed attribute (nested tuple) or a user-defined domain. Accept for now; full validation would require looking up the target relation's schema. *) - true + true in let n_expected = List.length schema in (* fun tree_of tuple -> *) fun tuple -> - match tuple with - | Tuple.NonMaterialized _nm -> - (* begin match tree_of name with + match tuple with + | Tuple.NonMaterialized _nm -> + (* begin match tree_of name with | None -> false | Some t -> Merkle.member nm.hash t @@ -656,23 +583,19 @@ let build_membership_criteria Tuple.AttributeMap.mem attr_name nm.attributes) schema end *) - false - | Tuple.Materialized m -> - Tuple.AttributeMap.cardinal m.attributes = n_expected - && List.for_all - (fun (attr_name, domain_name) -> - match Tuple.AttributeMap.find_opt attr_name m.attributes with - | None -> false - | Some attr -> - value_conforms_to_domain domain_name attr.Attribute.value) - schema + false + | Tuple.Materialized m -> + Tuple.AttributeMap.cardinal m.attributes = n_expected + && List.for_all + (fun (attr_name, domain_name) -> + match Tuple.AttributeMap.find_opt attr_name m.attributes with + | None -> false + | Some attr -> value_conforms_to_domain domain_name attr.Attribute.value ) + schema (** Mutation direction for cascade constraint checking *) type mutation = Insert | Delete (** Context for a single tuple mutation, used by cascade checking *) -type mutation_context = { - target_relation : string; - transition : (string * Conventions.AbstractValue.t) list; - kind : mutation; - } +type mutation_context = + {target_relation: string; transition: (string * Conventions.AbstractValue.t) list; kind: mutation} diff --git a/lib/conventions.ml b/lib/conventions.ml index 9e18762..70f33cf 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -15,8 +15,7 @@ end module Cardinality = struct open Sexplib.Std - type t = Finite of int | ConstrainedFinite | AlephZero | Continuum - [@@deriving sexp] + type t = Finite of int | ConstrainedFinite | AlephZero | Continuum [@@deriving sexp] end module Purity = struct @@ -27,8 +26,7 @@ module AbstractValue = struct type t = Obj.t type value_type = Int | String | Float | Opaque - let hash (elem : t) = - Sha256.to_hex (Sha256.string (Bytes.to_string (Marshal.to_bytes elem []))) + let hash (elem : t) = Sha256.to_hex (Sha256.string (Bytes.to_string (Marshal.to_bytes elem []))) let type_of (elem : t) : value_type = let tag = Obj.tag elem in @@ -43,17 +41,15 @@ module AbstractValue = struct | Int -> Atom (string_of_int (Obj.obj v : int)) | String -> Atom (Obj.obj v : string) | Float -> - let f = (Obj.obj v : float) in - if Float.is_nan f || Float.is_infinite f - then Atom "nan" - else Atom (string_of_float f) + let f = (Obj.obj v : float) in + if Float.is_nan f || Float.is_infinite f then Atom "nan" else Atom (string_of_float f) | Opaque -> Atom "<opaque>" let equal a b = - match (type_of a, type_of b) with - | (Int, Int) -> (Obj.obj a : int) = (Obj.obj b : int) - | (String, String) -> (Obj.obj a : string) = (Obj.obj b : string) - | (Float, Float) -> (Obj.obj a : float) = (Obj.obj b : float) - | (Opaque, Opaque) -> false - | (_, _) -> false + match type_of a, type_of b with + | Int, Int -> (Obj.obj a : int) = (Obj.obj b : int) + | String, String -> (Obj.obj a : string) = (Obj.obj b : string) + | Float, Float -> (Obj.obj a : float) = (Obj.obj b : float) + | Opaque, Opaque -> false + | _, _ -> false end diff --git a/lib/ddl/ast.ml b/lib/ddl/ast.ml index e1e5bad..86af755 100644 --- a/lib/ddl/ast.ml +++ b/lib/ddl/ast.ml @@ -1,16 +1,12 @@ open Sexplib.Std -type cardinality_spec = - | Finite of int - | AlephZero - | Continuum - | ConstrainedFinite +type cardinality_spec = Finite of int | AlephZero | Continuum | ConstrainedFinite [@@deriving sexp] type statement = | CreateMultigroup of string - | CreateRelation of { name : string; schema : (string * string) list } + | CreateRelation of {name: string; schema: (string * string) list} | RetractRelation of string | ClearRelation of string - | RegisterDomain of { name : string; cardinality : cardinality_spec } + | RegisterDomain of {name: string; cardinality: cardinality_spec} [@@deriving sexp] diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml index a47c911..c16ff1f 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -1,15 +1,17 @@ module Make (NT : Nt.S) = struct module Error = struct open Condition + (* TODO: more structure *) - let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) - let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name)) + let relation_not_found name = + condition "relation-not-found" "Relation not found" ("name" |=| of_string name) + + let multigroup_not_found name = + condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name) end let ( let* ) = Result.bind - - let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = - Qualified_name.try_parse s + let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : (Management.Multigroup.multigroup, Condition.t) result = @@ -17,8 +19,7 @@ module Make (NT : Nt.S) = struct | Some mg -> Ok mg | None -> Error (Error.multigroup_not_found mg_name) - let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t = - function + let convert_cardinality : Ast.cardinality_spec -> Conventions.Cardinality.t = function | Ast.Finite n -> Conventions.Cardinality.Finite n | Ast.AlephZero -> Conventions.Cardinality.AlephZero | Ast.Continuum -> Conventions.Cardinality.Continuum @@ -32,57 +33,49 @@ module Make (NT : Nt.S) = struct let bh = ctx.write_handle in let branch_name = ctx.branch#name in match stmt with - | Ast.CreateMultigroup name -> + | Ast.CreateMultigroup name -> ( ctx.branch#add_multigroup ~name; - (match ctx.branch#mg_of name with - | Some mg -> Ok ([ (name, mg) ], "Multigroup created: " ^ name) - | None -> Error (Error.multigroup_not_found name)) - | Ast.CreateRelation { name; schema = schema_pairs } -> + match ctx.branch#mg_of name with + | Some mg -> Ok ([name, mg], "Multigroup created: " ^ name) + | None -> Error (Error.multigroup_not_found name) ) + | Ast.CreateRelation {name; schema= schema_pairs} -> let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in let schema = - List.fold_left - (fun s (attr, dom) -> Schema.add attr dom s) - Schema.empty schema_pairs - in - let* _bh, new_mg = - NT.create_relation bh mg ~branch_name ~name:fqn.name ~schema + List.fold_left (fun s (attr, dom) -> Schema.add attr dom s) Schema.empty schema_pairs in + let* _bh, new_mg = NT.create_relation bh mg ~branch_name ~name:fqn.name ~schema in ctx.branch#set_mg ~name:fqn.mg new_mg; - Ok ([ (fqn.mg, new_mg) ], "Relation created: " ^ name) + Ok ([fqn.mg, new_mg], "Relation created: " ^ name) | Ast.RetractRelation name -> let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in - let* _bh, new_mg = - NT.retract_relation bh mg ~name:fqn.name - in + let* _bh, new_mg = NT.retract_relation bh mg ~name:fqn.name in ctx.branch#set_mg ~name:fqn.mg new_mg; - Ok ([ (fqn.mg, new_mg) ], "Relation retracted: " ^ name) - | Ast.ClearRelation name -> + Ok ([fqn.mg, new_mg], "Relation retracted: " ^ name) + | Ast.ClearRelation name -> ( let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in - (match mg#get_relation fqn.name with - | None -> Error (Error.relation_not_found name) - | Some rel -> - let* _bh, new_mg = - NT.clear_relation bh mg - ~branch_name ~mg_name:fqn.mg - (rel :> Relation.relation) - in - ctx.branch#set_mg ~name:fqn.mg new_mg; - Ok ([ (fqn.mg, new_mg) ], "Relation cleared: " ^ name)) - | Ast.RegisterDomain { name; cardinality } -> + match mg#get_relation fqn.name with + | None -> Error (Error.relation_not_found name) + | Some rel -> + let* _bh, new_mg = + NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg (rel :> Relation.relation) + in + ctx.branch#set_mg ~name:fqn.mg new_mg; + Ok ([fqn.mg, new_mg], "Relation cleared: " ^ name) ) + | Ast.RegisterDomain {name; cardinality} -> let* fqn = parse_fqn name in let* mg = lookup_mg ctx fqn.mg in let domain : Relation.domain = - new Relation.domain ~name:fqn.name + new Relation.domain + ~name:fqn.name ~generator:(fun _ -> Generator.Error "not enumerable via DDL") ~membership_criteria:(fun _ -> true) - ~cardinality:(convert_cardinality cardinality) - ~schema:Schema.empty ~provenance:None ~lineage:None - ~constraints:None + ~cardinality:(convert_cardinality cardinality) ~schema:Schema.empty ~provenance:None + ~lineage:None ~constraints:None in let* _bh, new_mg = NT.register_domain bh mg domain in ctx.branch#set_mg ~name:fqn.mg new_mg; - Ok ([ (fqn.mg, new_mg) ], "Domain registered: " ^ name) + Ok ([fqn.mg, new_mg], "Domain registered: " ^ name) end diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml index a4df914..094b0fd 100644 --- a/lib/ddl/parser.ml +++ b/lib/ddl/parser.ml @@ -1,5 +1,6 @@ module Error = struct open Condition + let parse_error msg = condition "parse-error" msg empty end diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml index 33145c4..da3ba3a 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -6,7 +6,6 @@ module Make (NT : Nt.S) = struct let name = "ddl" let parse _ = Ok () - let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = diff --git a/lib/dml/ast.ml b/lib/dml/ast.ml index 03e68ac..e34adb9 100644 --- a/lib/dml/ast.ml +++ b/lib/dml/ast.ml @@ -3,18 +3,17 @@ open Sexplib.Std type attr_value = string * Drl.Ast.value [@@deriving sexp] type statement = - | InsertTuple of { relation : string; attributes : attr_value list } - | InsertTuples of { relation : string; tuples : attr_value list list } - | DeleteTuple of { relation : string; attributes : attr_value list } - | Assign of { target : string; body : Drl.Ast.query } - | InsertFrom of { target : string; source : Drl.Ast.query } - | DeleteWhere of { target : string; predicate : Drl.Ast.query } - (** Binds an unqualified name to a session-scoped ephemeral relation. - The body is recomputed on each scan and never materialized; - the binding lives until [DropDefine] or a session close. - In contrast, [Assign] drains the body into an existing - stored relation. *) - | Define of { target : string; body : Drl.Ast.query } - (** Drops a [Define] binding, releasing its session-ownership pin. *) - | DropDefine of { target : string } + | InsertTuple of {relation: string; attributes: attr_value list} + | InsertTuples of {relation: string; tuples: attr_value list list} + | DeleteTuple of {relation: string; attributes: attr_value list} + | Assign of {target: string; body: Drl.Ast.query} + | InsertFrom of {target: string; source: Drl.Ast.query} + | DeleteWhere of {target: string; predicate: Drl.Ast.query} + (** Binds an unqualified name to a session-scoped ephemeral relation. The + body is recomputed on each scan and never materialized; the binding + lives until [DropDefine] or a session close. In contrast, [Assign] + drains the body into an existing stored relation. *) + | Define of {target: string; body: Drl.Ast.query} + (** Drops a [Define] binding, releasing its session-ownership pin. *) + | DropDefine of {target: string} [@@deriving sexp] diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml index d5c55f8..f034f4a 100644 --- a/lib/dml/executor.ml +++ b/lib/dml/executor.ml @@ -3,16 +3,19 @@ module Make (NT : Nt.S) = struct module Error = struct open Condition + (* TODO: more structure *) let parse_error msg = condition "parse-error" msg empty - let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) - let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name)) + + let relation_not_found name = + condition "relation-not-found" "Relation not found" ("name" |=| of_string name) + + let multigroup_not_found name = + condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name) end let ( let* ) = Result.bind - - let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = - Qualified_name.try_parse s + let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : (Management.Multigroup.multigroup, Condition.t) result = @@ -26,27 +29,22 @@ module Make (NT : Nt.S) = struct | Some r -> Ok r | None -> Error (Error.relation_not_found (Qualified_name.to_string fqn)) - let retarget target (t : Tuple.materialized) = - { t with Tuple.relation = target } + let retarget target (t : Tuple.materialized) = {t with Tuple.relation= target} let build_tuple ~relation (attributes : Ast.attr_value list) : Tuple.materialized = let attr_map = List.fold_left (fun acc (name, value) -> - Tuple.AttributeMap.add name - { Attribute.value = Drl.Ast.value_to_abstract value } - acc) + Tuple.AttributeMap.add name {Attribute.value= Drl.Ast.value_to_abstract value} acc ) Tuple.AttributeMap.empty attributes in - { Tuple.relation; attributes = attr_map } + {Tuple.relation; attributes= attr_map} (* Drain all tuples from a DRL query using ctx.resolve for path resolution. Cross-multigroup reads work transparently here. *) let drain_query (ctx : Sublanguage_context.t) query = let* plan = DrlExec.compile ctx query in - let* stream = - NT.execute_query plan ~rel_name:"dml_drain" - in + let* stream = NT.execute_query plan ~rel_name:"dml_drain" in let rec drain acc = match NT.stream_next stream with | Error _ -> List.rev acc @@ -60,38 +58,36 @@ module Make (NT : Nt.S) = struct (* Stored-relation paths referenced by a query, for ephemeral dependency pinning. A qualified leaf resolves through ctx; an unqualified one is a previously Defined session ephemeral (views compose). *) - let rec base_dep_paths (ctx : Sublanguage_context.t) (q : Drl.Ast.query) : - string list = + let rec base_dep_paths (ctx : Sublanguage_context.t) (q : Drl.Ast.query) : string list = match q with - | Drl.Ast.Base name -> - (match Qualified_name.try_parse name with - | Ok fqn -> [ ctx.resolve fqn ] - | Error _ -> [ Sublanguage_context.ephemeral_path ctx name ]) + | Drl.Ast.Base name -> ( + match Qualified_name.try_parse name with + | Ok fqn -> [ctx.resolve fqn] + | Error _ -> [Sublanguage_context.ephemeral_path ctx name] ) | Drl.Ast.Const _ -> [] | Drl.Ast.Select (a, b) - | Drl.Ast.Join (_, a, b) - | Drl.Ast.Cartesian (a, b) - | Drl.Ast.Union (a, b) - | Drl.Ast.Diff (a, b) -> base_dep_paths ctx a @ base_dep_paths ctx b - | Drl.Ast.Project (_, s) - | Drl.Ast.Rename (_, s) - | Drl.Ast.Take (_, s) -> base_dep_paths ctx s + |Drl.Ast.Join (_, a, b) + |Drl.Ast.Cartesian (a, b) + |Drl.Ast.Union (a, b) + |Drl.Ast.Diff (a, b) -> + base_dep_paths ctx a @ base_dep_paths ctx b + | Drl.Ast.Project (_, s) | Drl.Ast.Rename (_, s) | Drl.Ast.Take (_, s) -> base_dep_paths ctx s (* Schema of a query result, walked structurally from the base relations' schemas. Mirrors the operator semantics in docs/relational-algebra.org. *) let rec infer_schema (ctx : Sublanguage_context.t) (q : Drl.Ast.query) : (Schema.t, Condition.t) result = match q with - | Drl.Ast.Base name -> - (match Qualified_name.try_parse name with - | Error _ -> - (* Session ephemeral: RNT owns its schema; nothing to derive + | Drl.Ast.Base name -> ( + match Qualified_name.try_parse name with + | Error _ -> + (* Session ephemeral: RNT owns its schema; nothing to derive on the OCaml-side, so treated as contributing no attributes. *) - Ok [] - | Ok fqn -> - let* rel = get_rel ctx fqn in - Ok rel#schema) - | Drl.Ast.Const attrs -> Ok (List.map (fun (n, _) -> (n, "abstract")) attrs) + Ok [] + | Ok fqn -> + let* rel = get_rel ctx fqn in + Ok rel#schema ) + | Drl.Ast.Const attrs -> Ok (List.map (fun (n, _) -> n, "abstract") attrs) | Drl.Ast.Select (_, src) -> infer_schema ctx src | Drl.Ast.Join (_, l, r) | Drl.Ast.Cartesian (l, r) -> let* ls = infer_schema ctx l in @@ -102,31 +98,28 @@ module Make (NT : Nt.S) = struct Ok (List.filter (fun (n, _) -> List.mem n attrs) s) | Drl.Ast.Rename (renames, src) -> let* s = infer_schema ctx src in - Ok (List.map (fun (n, d) -> - match List.assoc_opt n renames with - | Some n' -> (n', d) - | None -> (n, d)) s) + Ok + (List.map + (fun (n, d) -> match List.assoc_opt n renames with Some n' -> n', d | None -> n, d) + s ) | Drl.Ast.Union (l, _) | Drl.Ast.Diff (l, _) -> infer_schema ctx l | Drl.Ast.Take (_, src) -> infer_schema ctx src - let attr_val_eq a b = - Stdlib.( = ) a.Attribute.value b.Attribute.value - - let tuple_matches_pred common (target_t : Tuple.materialized) - (pred_t : Tuple.materialized) = - List.for_all (fun attr -> - match - ( Tuple.AttributeMap.find_opt attr target_t.Tuple.attributes, - Tuple.AttributeMap.find_opt attr pred_t.Tuple.attributes ) - with - | Some a, Some b -> attr_val_eq a b - | _ -> false) + let attr_val_eq a b = Stdlib.( = ) a.Attribute.value b.Attribute.value + + let tuple_matches_pred common (target_t : Tuple.materialized) (pred_t : Tuple.materialized) = + List.for_all + (fun attr -> + match + ( Tuple.AttributeMap.find_opt attr target_t.Tuple.attributes, + Tuple.AttributeMap.find_opt attr pred_t.Tuple.attributes ) + with + | Some a, Some b -> attr_val_eq a b + | _ -> false ) common let semijoin common target_tuples pred_tuples = - List.filter - (fun t -> List.exists (tuple_matches_pred common t) pred_tuples) - target_tuples + List.filter (fun t -> List.exists (tuple_matches_pred common t) pred_tuples) target_tuples (* DML mutates tuples in a single mg per statement. Returns a single-element transition delta keyed by that mg's name. *) @@ -134,52 +127,44 @@ module Make (NT : Nt.S) = struct (Sublanguage_types.transition_delta, Condition.t) result = let bh = ctx.write_handle in let branch_name = ctx.branch#name in - let after fqn = Result.bind (lookup_mg ctx fqn.Qualified_name.mg) - (fun mg -> Ok [ (fqn.Qualified_name.mg, mg) ]) + let after fqn = + Result.bind (lookup_mg ctx fqn.Qualified_name.mg) (fun mg -> Ok [fqn.Qualified_name.mg, mg]) in match stmt with - | Ast.InsertTuple { relation; attributes } -> + | Ast.InsertTuple {relation; attributes} -> let* fqn = parse_fqn relation in let* rel = get_rel ctx fqn in let tuple = build_tuple ~relation:rel#name attributes in - let* _ = - NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple - in + let* _ = NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple in after fqn - | Ast.InsertTuples { relation; tuples } -> + | Ast.InsertTuples {relation; tuples} -> let* fqn = parse_fqn relation in let* rel = get_rel ctx fqn in let tuple_list = List.map (build_tuple ~relation:rel#name) tuples in - let* _ = - NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name - tuple_list - in + let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple_list in after fqn - | Ast.DeleteTuple { relation; attributes } -> + | Ast.DeleteTuple {relation; attributes} -> let* fqn = parse_fqn relation in let* rel = get_rel ctx fqn in let tuple = build_tuple ~relation:rel#name attributes in let hash = Hashing.hash_tuple tuple in - let* () = - NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash - in + let* () = NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash in after fqn - | Ast.Assign { target; body } -> + | Ast.Assign {target; body} -> let* fqn = parse_fqn target in - let* mg = lookup_mg ctx fqn.mg in + let* mg = lookup_mg ctx fqn.mg in let* rel = get_rel ctx fqn in let* tuples = drain_query ctx body in let* _bh, new_mg = - NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg - (rel :> Relation.relation) + NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg (rel :> Relation.relation) in ctx.branch#set_mg ~name:fqn.mg new_mg; let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name (List.map (retarget rel#name) tuples) in - Ok [ (fqn.mg, new_mg) ] - | Ast.InsertFrom { target; source } -> + Ok [fqn.mg, new_mg] + | Ast.InsertFrom {target; source} -> let* fqn = parse_fqn target in let* rel = get_rel ctx fqn in let* tuples = drain_query ctx source in @@ -188,11 +173,11 @@ module Make (NT : Nt.S) = struct (List.map (retarget rel#name) tuples) in after fqn - | Ast.Define { target; body } -> + | Ast.Define {target; body} -> let* () = if String.contains target ':' then - Error (Error.parse_error - ("Define target must be unqualified (session-scoped): " ^ target)) + Error + (Error.parse_error ("Define target must be unqualified (session-scoped): " ^ target)) else Ok () in (* TODO: redefining an existing name isn't guarded. Right now we lean on @@ -204,35 +189,29 @@ module Make (NT : Nt.S) = struct time. Push the offset/limit down or cache the result. *) let generator ~offset ~limit = match drain_query ctx body with - | Error _ -> [] - | Ok tuples -> - List.filteri (fun i _ -> i >= offset && i < offset + limit) tuples + | Error _ -> [] + | Ok tuples -> List.filteri (fun i _ -> i >= offset && i < offset + limit) tuples in let* _path = - NT.register_ephemeral ~session:ctx.session_hash ~named:true - ~name:target ~generator + NT.register_ephemeral ~session:ctx.session_hash ~named:true ~name:target ~generator ~cardinality:Conventions.Cardinality.ConstrainedFinite - ~identity:(Drl.Parser.to_string body) ~schema - ~deps:(base_dep_paths ctx body) + ~identity:(Drl.Parser.to_string body) ~schema ~deps:(base_dep_paths ctx body) in Ok [] - | Ast.DropDefine { target } -> - let* () = - NT.drop_ephemeral ~session:ctx.session_hash ~name:target - in + | Ast.DropDefine {target} -> + let* () = NT.drop_ephemeral ~session:ctx.session_hash ~name:target in Ok [] - | Ast.DeleteWhere { target; predicate } -> + | Ast.DeleteWhere {target; predicate} -> let* fqn = parse_fqn target in let* rel = get_rel ctx fqn in let* target_tuples = drain_query ctx (Drl.Ast.Base target) in - let* pred_tuples = drain_query ctx predicate in + let* pred_tuples = drain_query ctx predicate in let attr_names_of = function | [] -> [] - | t :: _ -> - List.map fst (Tuple.AttributeMap.bindings t.Tuple.attributes) + | t :: _ -> List.map fst (Tuple.AttributeMap.bindings t.Tuple.attributes) in let target_attrs = attr_names_of target_tuples in - let pred_attrs = attr_names_of pred_tuples in + let pred_attrs = attr_names_of pred_tuples in let common = List.filter (fun n -> List.mem n pred_attrs) target_attrs in let to_delete = semijoin common target_tuples pred_tuples in let* () = @@ -240,8 +219,7 @@ module Make (NT : Nt.S) = struct (fun acc t -> let* () = acc in let hash = Hashing.hash_tuple (retarget rel#name t) in - NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name - hash) + NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash ) (Ok ()) to_delete in after fqn diff --git a/lib/dml/parser.ml b/lib/dml/parser.ml index a4df914..094b0fd 100644 --- a/lib/dml/parser.ml +++ b/lib/dml/parser.ml @@ -1,5 +1,6 @@ module Error = struct open Condition + let parse_error msg = condition "parse-error" msg empty end diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index 9648786..6e9d2c8 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -6,7 +6,6 @@ module Make (NT : Nt.S) = struct let name = "dml" let parse _ = Ok () - let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = diff --git a/lib/drl/ast.ml b/lib/drl/ast.ml index 6b191bb..2fd56e6 100644 --- a/lib/drl/ast.ml +++ b/lib/drl/ast.ml @@ -1,8 +1,7 @@ open Sexplib.Std (** Literal values for Const nodes *) -type value = Int of int | Float of float | Str of string | Bool of bool -[@@deriving sexp] +type value = Int of int | Float of float | Str of string | Bool of bool [@@deriving sexp] (** Convert an AST value to an AbstractValue.t (Obj.t) via Obj.repr *) let value_to_abstract : value -> Conventions.AbstractValue.t = function @@ -17,8 +16,7 @@ type query = | Base of string (** base relation by name *) | Const of (string * value) list (** constant single-tuple relation *) | Select of query * query (** σ semijoin: (filter, source) *) - | Join of string list * query * query - (** ⋈ natural equijoin on named attrs *) + | Join of string list * query * query (** ⋈ natural equijoin on named attrs *) | Cartesian of query * query (** × Cartesian product *) | Project of string list * query (** π restrict columns *) | Rename of (string * string) list * query (** ρ rename (old,new) pairs *) diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index fffea19..6ff3551 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -3,7 +3,10 @@ module Make (NT : Nt.S) = struct open Condition let parse_error error = condition "parse-error" error empty - let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) + + let relation_not_found name = + condition "relation-not-found" "Relation not found" ("name" |=| of_string name) + let unsupported_operator msg = condition "unsupported-operator" msg empty end @@ -13,33 +16,30 @@ module Make (NT : Nt.S) = struct A qualified base reference ([<mg>:<rel>]) resolves through [ctx.resolve] to its stored-relation path; an unqualified name resolves to the session-scoped ephemeral binding created by DML [Define]. *) - let rec compile - (ctx : Sublanguage_context.t) - (q : Ast.query) : (Nt.plan_node, Condition.t) result = + let rec compile (ctx : Sublanguage_context.t) (q : Ast.query) : (Nt.plan_node, Condition.t) result + = match q with - | Ast.Base name -> - (match Qualified_name.try_parse name with - | Error _ -> - Ok (Nt.Scan - { path = Sublanguage_context.ephemeral_path ctx name; - args = [] }) - | Ok fqn -> Ok (Nt.Scan { path = ctx.resolve fqn; args = [] })) + | Ast.Base name -> ( + match Qualified_name.try_parse name with + | Error _ -> Ok (Nt.Scan {path= Sublanguage_context.ephemeral_path ctx name; args= []}) + | Ok fqn -> Ok (Nt.Scan {path= ctx.resolve fqn; args= []}) ) | Ast.Join (on_attrs, q1, q2) -> let* p1 = compile ctx q1 in let* p2 = compile ctx q2 in - Ok (Nt.Join { left = p1; right = p2; on_attrs }) + Ok (Nt.Join {left= p1; right= p2; on_attrs}) | Ast.Take (n, q) -> let* p = compile ctx q in - Ok (Nt.Take { limit = n; source = p }) + Ok (Nt.Take {limit= n; source= p}) | Ast.Project (attrs, q) -> let* p = compile ctx q in - Ok (Nt.Project { attrs; source = p }) + Ok (Nt.Project {attrs; source= p}) | Ast.Const _ -> - Error (Error.unsupported_operator - "Const: literal relations not yet reachable by VM; use Base") + Error + (Error.unsupported_operator "Const: literal relations not yet reachable by VM; use Base") | _ -> - Error (Error.unsupported_operator - "Select/Rename/Union/Diff/Cartesian require VM operators not yet implemented") + Error + (Error.unsupported_operator + "Select/Rename/Union/Diff/Cartesian require VM operators not yet implemented" ) let page_limit = 16 @@ -47,17 +47,16 @@ module Make (NT : Nt.S) = struct (Sublanguage_types.result, Condition.t) result = let* plan = compile ctx q in let rel_name = "query_result" in - let* stream = NT.execute_query plan ~rel_name - in + let* stream = NT.execute_query plan ~rel_name in let rec drain acc count = - if count >= page_limit then (List.rev acc, true) + if count >= page_limit then List.rev acc, true else match NT.stream_next stream with - | Error _ -> (List.rev acc, false) - | Ok None -> (List.rev acc, false) + | Error _ -> List.rev acc, false + | Ok None -> List.rev acc, false | Ok (Some t) -> drain (t :: acc) (count + 1) in - let (rows, has_more) = drain [] 0 in + let rows, has_more = drain [] 0 in ignore (NT.stream_close stream); - Ok (Sublanguage_types.Cursor { cursor_id = "0"; rows; has_more }) + Ok (Sublanguage_types.Cursor {cursor_id= "0"; rows; has_more}) end diff --git a/lib/drl/parser.ml b/lib/drl/parser.ml index be1f1eb..abb3070 100644 --- a/lib/drl/parser.ml +++ b/lib/drl/parser.ml @@ -1,5 +1,6 @@ module Error = struct open Condition + let parse_error msg = condition "parse-error" msg empty end diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml index 64cd8c0..d5c5977 100644 --- a/lib/drl/sublanguage.ml +++ b/lib/drl/sublanguage.ml @@ -6,8 +6,6 @@ module Make (NT : Nt.S) = struct let name = "drl" let parse _ = Ok () - let parse_sexp sexp = Parser.of_sexp sexp - let execute ctx ast = Exec.execute ctx ast end diff --git a/lib/error.ml b/lib/error.ml index b19aebb..4f1cecd 100644 --- a/lib/error.ml +++ b/lib/error.ml @@ -10,33 +10,26 @@ 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.Multigroup.multigroup; - new_db : Management.Multigroup.multigroup; - } + | Conflict of {old_db: Management.Multigroup.multigroup; new_db: Management.Multigroup.multigroup} | 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" <+> Atom old_db#name; "new" <+> Atom new_db#name ] + | 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" <+> Atom old_db#name; "new" <+> Atom new_db#name] diff --git a/lib/generator.ml b/lib/generator.ml index 5939ec9..5f0a50f 100644 --- a/lib/generator.ml +++ b/lib/generator.ml @@ -1,6 +1,2 @@ -type result = - | Done - | Value of Tuple.t * (int option -> result) - | Error of string - +type result = Done | Value of Tuple.t * (int option -> result) | Error of string and t = int option -> result diff --git a/lib/hashing.ml b/lib/hashing.ml index ff8436b..cc4bf10 100644 --- a/lib/hashing.ml +++ b/lib/hashing.ml @@ -16,9 +16,7 @@ let bytes_to_hex bytes = let hi = c lsr 4 in let lo = c land 0xf in Bytes.set hex (i * 2) (Char.chr (if hi < 10 then hi + 48 else hi + 87)); - Bytes.set hex - ((i * 2) + 1) - (Char.chr (if lo < 10 then lo + 48 else lo + 87)) + Bytes.set hex ((i * 2) + 1) (Char.chr (if lo < 10 then lo + 48 else lo + 87)) done; Bytes.to_string hex @@ -35,11 +33,9 @@ let hash_tuple (tuple : Tuple.materialized) : Conventions.Hash.t = List.fold_left (fun acc (name, attr) -> (* Marshal the value and hex-encode to avoid null bytes *) - let value_bytes = - Marshal.to_bytes attr.Attribute.value [ Marshal.Closures ] - in + let value_bytes = Marshal.to_bytes attr.Attribute.value [Marshal.Closures] in let value_hex = bytes_to_hex value_bytes in - acc ^ name ^ ":" ^ value_hex ^ ";") + acc ^ name ^ ":" ^ value_hex ^ ";" ) (tuple.relation ^ "|") sorted_attrs in Conventions.Hash.hash_text content diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml index 30b0fa7..1a5b096 100644 --- a/lib/icl/ast.ml +++ b/lib/icl/ast.ml @@ -1,23 +1,17 @@ open Sexplib.Std -type binding_expr = - | Var of string - | Const of Drl.Ast.value (** reuse DRL value for literals *) +type binding_expr = Var of string | Const of Drl.Ast.value (** reuse DRL value for literals *) [@@deriving sexp] type constraint_body = - | MemberOf of { target : string; binding : (string * binding_expr) list } - | Not of { body : constraint_body; universe : string } + | MemberOf of {target: string; binding: (string * binding_expr) list} + | Not of {body: constraint_body; universe: string} | And of constraint_body list | Or of constraint_body list - | Exists of { variable : string; quantifier : string; body : constraint_body } - | Forall of { variable : string; quantifier : string; body : constraint_body } + | Exists of {variable: string; quantifier: string; body: constraint_body} + | Forall of {variable: string; quantifier: string; body: constraint_body} [@@deriving sexp] type statement = - | RegisterConstraint of { - constraint_name : string; - relation_name : string; - body : constraint_body; - } + | RegisterConstraint of {constraint_name: string; relation_name: string; body: constraint_body} [@@deriving sexp] diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml index 084fb71..dd0a1d9 100644 --- a/lib/icl/executor.ml +++ b/lib/icl/executor.ml @@ -1,13 +1,13 @@ module Make (NT : Nt.S) = struct module Error = struct open Condition - let multigroup_not_found name = condition "multigroup-not-found" "Multigroup not found" ("name" |=| (of_string name)) + + let multigroup_not_found name = + condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name) end let ( let* ) = Result.bind - - let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = - Qualified_name.try_parse s + let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) : (Management.Multigroup.multigroup, Condition.t) result = @@ -15,43 +15,39 @@ module Make (NT : Nt.S) = struct | Some mg -> Ok mg | None -> Error (Error.multigroup_not_found mg_name) - let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = - function + let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function | Ast.Var name -> Constraint.Var name | Ast.Const value -> Constraint.Const (Drl.Ast.value_to_abstract value) - let convert_binding (pairs : (string * Ast.binding_expr) list) : - Constraint.binding = + let convert_binding (pairs : (string * Ast.binding_expr) list) : Constraint.binding = List.fold_left - (fun acc (key, expr) -> - Constraint.BindingMap.add key (convert_binding_expr expr) acc) + (fun acc (key, expr) -> Constraint.BindingMap.add key (convert_binding_expr expr) acc) Constraint.BindingMap.empty pairs let rec convert_body : Ast.constraint_body -> Constraint.t = function - | Ast.MemberOf { target; binding } -> + | Ast.MemberOf {target; binding} -> Constraint.member_of ~target ~binding:(convert_binding binding) - | Ast.Not { body; universe } -> - Constraint.not_ ~universe (convert_body body) + | Ast.Not {body; universe} -> Constraint.not_ ~universe (convert_body body) | Ast.And bodies -> Constraint.and_ (List.map convert_body bodies) | Ast.Or bodies -> Constraint.or_ (List.map convert_body bodies) - | Ast.Exists { variable; quantifier; body } -> + | Ast.Exists {variable; quantifier; body} -> Constraint.exists ~variable ~quantifier (convert_body body) - | Ast.Forall { variable; quantifier; body } -> + | Ast.Forall {variable; quantifier; body} -> Constraint.forall ~variable ~quantifier (convert_body body) let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) : (Sublanguage_types.transition_delta * string, Condition.t) result = match stmt with - | Ast.RegisterConstraint { constraint_name; relation_name; body } -> + | Ast.RegisterConstraint {constraint_name; relation_name; body} -> let* fqn = parse_fqn relation_name in - let* mg = lookup_mg ctx fqn.mg in + let* mg = lookup_mg ctx fqn.mg in let runtime_body = convert_body body in let* _bh, new_mg = - NT.register_constraint ctx.write_handle mg - ~constraint_name ~relation_name:fqn.name ~body:runtime_body + NT.register_constraint ctx.write_handle mg ~constraint_name ~relation_name:fqn.name + ~body:runtime_body in ctx.branch#set_mg ~name:fqn.mg new_mg; - Ok ([ (fqn.mg, new_mg) ], "Constraint registered: " ^ constraint_name) + Ok ([fqn.mg, new_mg], "Constraint registered: " ^ constraint_name) end module Memory = Make (Nt.Memory) diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml index a4df914..094b0fd 100644 --- a/lib/icl/parser.ml +++ b/lib/icl/parser.ml @@ -1,5 +1,6 @@ module Error = struct open Condition + let parse_error msg = condition "parse-error" msg empty end diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index 19f15ce..c68077d 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -6,7 +6,6 @@ module Make (NT : Nt.S) = struct let name = "icl" let parse _ = Ok () - let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = diff --git a/lib/listener.ml b/lib/listener.ml index b3090a7..5a7560f 100644 --- a/lib/listener.ml +++ b/lib/listener.ml @@ -7,58 +7,47 @@ functor module type SubS = Sublanguage.S module Sess = Session.Make (NT) - module B = Branch.Make (NT) - module SC = Sublanguage_context.Make (NT) + module B = Branch.Make (NT) + module SC = Sublanguage_context.Make (NT) module Error = struct open Condition - let syntax_error msg = - condition "syntax-error" msg empty + let syntax_error msg = condition "syntax-error" msg empty let unrecognized_sublanguage tag = - condition "unrecognized-sublanguage" "Unrecognized sublanguage" - ("tag" |=| (of_string tag)) + condition "unrecognized-sublanguage" "Unrecognized sublanguage" ("tag" |=| of_string tag) let malformed_expression expr = - condition "malformed-expression" "Malformed expression" - ("expression" |=| (of_sexp expr)) + condition "malformed-expression" "Malformed expression" ("expression" |=| of_sexp expr) end - (** Per-connection state: session owns the active branch. The - branch's [relation_path] becomes the context resolver, so all - sublanguages address the full RNT namespace rather than a - single multigroup. **) - type conn_state = { - claims : Nt.claims; - session : Sess.session; - } - - (** Build a fresh execution context from the current session - state. Called at the top of every handle_sublanguage so it - always reflects the live branch after any prior VCL - switch. **) - let make_ctx ({ session; claims } : conn_state) : Sublanguage_context.t = + (** Per-connection state: session owns the active branch. The branch's + [relation_path] becomes the context resolver, so all sublanguages + address the full RNT namespace rather than a single multigroup. **) + type conn_state = {claims: Nt.claims; session: Sess.session} + + (** Build a fresh execution context from the current session state. Called + at the top of every handle_sublanguage so it always reflects the live + branch after any prior VCL switch. **) + let make_ctx ({session; claims} : conn_state) : Sublanguage_context.t = SC.make_ctx session claims let read_command input = try Ok (Sexplib.Sexp.input_sexp input) - with Sexplib.Sexp.Parse_error { err_msg; _ } -> - Error (Error.syntax_error err_msg) + with Sexplib.Sexp.Parse_error {err_msg; _} -> Error (Error.syntax_error err_msg) let sublanguages = List.fold_right (fun (module Language : SubS) -> - Utilities.StringMap.add Language.name (module Language : SubS)) - [ - (module Drl.Sublanguage.Make (NT) : SubS); + Utilities.StringMap.add Language.name (module Language : SubS) ) + [ (module Drl.Sublanguage.Make (NT) : SubS); (module Ddl.Sublanguage.Make (NT) : SubS); (module Dml.Sublanguage.Make (NT) : SubS); (module Icl.Sublanguage.Make (NT) : SubS); (module Prl.Sublanguage.Make (NT) : SubS); (module Scl.Sublanguage.Make (NT) : SubS); - (module Vcl.Sublanguage.Make (NT) : SubS); - ] + (module Vcl.Sublanguage.Make (NT) : SubS) ] Utilities.StringMap.empty let find_language tag = @@ -66,20 +55,19 @@ functor |> Option.to_result ~none:(Error.unrecognized_sublanguage tag) let execute_sublanguage ctx expr (module Language : SubS) = - Language.parse_sexp expr - |> Utilities.Result.fmap (Language.execute ctx) + Language.parse_sexp expr |> Utilities.Result.fmap (Language.execute ctx) let execute_command ctx = function - | Sexplib.Sexp.(List [ Atom tag; expr ]) -> + | Sexplib.Sexp.(List [Atom tag; expr]) -> find_language tag |> Utilities.Result.fmap (execute_sublanguage ctx expr) | s -> Error (Error.malformed_expression s) let tuple_to_sexp (t : Tuple.materialized) = let open Sexplib.Sexp in List - (Tuple.AttributeMap.bindings t.Tuple.attributes + ( Tuple.AttributeMap.bindings t.Tuple.attributes |> List.map (fun (k, attr) -> - List [ Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value ])) + List [Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value] ) ) let output_response out_ch sexp = let response = Sexplib.Sexp.to_string sexp in @@ -89,40 +77,35 @@ functor Utilities.print_with_time response let send_error out_ch e = - output_response out_ch - Sexplib.Sexp.(List [ Atom "error"; Condition.to_sexp e ]) + output_response out_ch Sexplib.Sexp.(List [Atom "error"; Condition.to_sexp e]) (* Serializes a sublanguage result. [branch] is the write target whose tip and name surface in Cursor / Transition responses. *) let serialize (branch : B.branch) = let open Sexplib.Sexp in function - | Error e -> List [ Atom "error"; Condition.to_sexp e ] - | Ok (Sublanguage_types.Cursor { cursor_id; rows; has_more }) -> + | Error e -> List [Atom "error"; Condition.to_sexp e] + | Ok (Sublanguage_types.Cursor {cursor_id; rows; has_more}) -> let row_sexps = List.map tuple_to_sexp rows in List - [ - Atom "cursor"; - List [ Atom "id"; Atom cursor_id ]; - List [ Atom "rows"; List row_sexps ]; - List [ Atom "row_count"; Atom (string_of_int (List.length row_sexps)) ]; - List [ Atom "has_more"; Atom (string_of_bool has_more) ]; - List [ Atom "snapshot"; Atom branch#tip ]; - List [ Atom "branch"; Atom branch#name ]; - ] + [ Atom "cursor"; + List [Atom "id"; Atom cursor_id]; + List [Atom "rows"; List row_sexps]; + List [Atom "row_count"; Atom (string_of_int (List.length row_sexps))]; + List [Atom "has_more"; Atom (string_of_bool has_more)]; + List [Atom "snapshot"; Atom branch#tip]; + List [Atom "branch"; Atom branch#name] ] | Ok (Sublanguage_types.Query _rel) -> - List [ Atom "error"; Atom "unexpected Query result: use Cursor path" ] + List [Atom "error"; Atom "unexpected Query result: use Cursor path"] | Ok (Sublanguage_types.Transition _new_cache) -> List - [ - Atom "ok"; - List [ Atom "snapshot"; Atom branch#tip ]; - List [ Atom "branch"; Atom branch#name ]; - ] + [ Atom "ok"; + List [Atom "snapshot"; Atom branch#tip]; + List [Atom "branch"; Atom branch#name] ] | Ok (Sublanguage_types.SessionSwitch name) -> - List [ Atom "ok"; List [ Atom "message"; Atom ("Switched to branch " ^ name) ] ] + List [Atom "ok"; List [Atom "message"; Atom ("Switched to branch " ^ name)]] | Ok (Sublanguage_types.CreateMultigroup name) -> - List [ Atom "ok"; List [ Atom "message"; Atom ("Multigroup " ^ name ^ " created") ] ] + List [Atom "ok"; List [Atom "message"; Atom ("Multigroup " ^ name ^ " created")]] let handle_sublanguage output state sexp = let ctx = make_ctx !state in @@ -133,39 +116,36 @@ functor state-advancing result (DDL, ICL, VCL). For VCL the session already holds the new branch; refresh_mg is a no-op on it but correct for DDL/ICL which stay on the same branch. *) - (match result with - | Sublanguage_types.Transition delta -> - !state.session#branch#apply_delta delta - | _ -> ()); + ( match result with + | Sublanguage_types.Transition delta -> !state.session#branch#apply_delta delta + | _ -> () ); serialize !state.session#branch (Ok result) |> output_response output let handle_client connection = - let input = T.input connection in + let input = T.input connection in let output = T.output connection in match NT.authenticate Nt.PlainText with | Error e -> (* FIXME: why is this a syntax error? *) send_error output e - | Ok claims -> - (match Sess.open_session claims ~branch_name:"master" with - | Error e -> - send_error output e - | Ok sess -> - let state = ref { claims; session = sess } in - (try - while true do - match read_command input with - | Error e -> send_error output e - | Ok sexp -> handle_sublanguage output state sexp - done - with - | End_of_file -> ignore (!state.session#close ()) - | e -> - ignore (!state.session#close ()); - Printf.eprintf "Error handling connection: %s" (Printexc.to_string e))) - - let spawn_handler connection = - Stdlib.Domain.spawn (fun () -> handle_client connection) + | Ok claims -> ( + match Sess.open_session claims ~branch_name:"master" with + | Error e -> send_error output e + | Ok sess -> ( + let state = ref {claims; session= sess} in + try + while true do + match read_command input with + | Error e -> send_error output e + | Ok sexp -> handle_sublanguage output state sexp + done + with + | End_of_file -> ignore (!state.session#close ()) + | e -> + ignore (!state.session#close ()); + Printf.eprintf "Error handling connection: %s" (Printexc.to_string e) ) ) + + let spawn_handler connection = Stdlib.Domain.spawn (fun () -> handle_client connection) let run transport = T.listen transport; diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 4ba0983..1583b9b 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -4,7 +4,7 @@ - "branch_names" -> serialized string list (index for enumeration) - "head" -> branch name as raw bytes *) -type t = { name : string; tip : Conventions.Hash.t } +type t = {name: string; tip: Conventions.Hash.t} type head = string type error = string @@ -15,7 +15,9 @@ let names_key = "branch_names" module Make (Storage : Physical.S) = struct module Error = struct open Condition - let branch_not_found name = condition "branch-not-found" "Branch not found" ("name" |=| (of_string name)) + + let branch_not_found name = + condition "branch-not-found" "Branch not found" ("name" |=| of_string name) end let load_names storage = @@ -28,7 +30,7 @@ module Make (Storage : Physical.S) = struct ignore (Storage.store_raw storage names_key bytes) let create storage ~name ~tip = - let record = { name; tip } in + let record = {name; tip} in let bytes = Marshal.to_bytes record [] in match Storage.store_raw storage (branch_key name) bytes with | Error e -> Error e @@ -58,7 +60,7 @@ module Make (Storage : Physical.S) = struct let update_tip storage ~name ~tip = match Storage.load_raw storage (branch_key name) with | Ok (Some _) -> - let record = { name; tip } in + let record = {name; tip} in let bytes = Marshal.to_bytes record [] in Storage.store_raw storage (branch_key name) bytes | Ok None -> Error (Error.branch_not_found name) @@ -68,14 +70,11 @@ module Make (Storage : Physical.S) = struct let names = load_names storage in let branches = List.filter_map - (fun name -> - match get_tip storage name with - | Ok (Some tip) -> Some (name, tip) - | _ -> None) + (fun name -> match get_tip storage name with Ok (Some tip) -> Some (name, tip) | _ -> None) names in Ok branches -(* + (* let branch_relation storage : Relation.t = let schema = Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string" diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml index b908302..2882afa 100644 --- a/lib/management/multigroup.ml +++ b/lib/management/multigroup.ml @@ -2,13 +2,11 @@ to content-addressed relation values. The multigroup object owns the B+ tree pointer and advances it when relations change. *) - class multigroup ~name:(init_name : Conventions.Name.t) = object (_self) val name : Conventions.Name.t = init_name val relations : Relation.relation BatMap.String.t = BatMap.String.empty val timestamp : float = Unix.gettimeofday () - method name = name method relations = relations method timestamp = timestamp @@ -19,21 +17,19 @@ class multigroup ~name:(init_name : Conventions.Name.t) = method has_relation rel_name = BatMap.String.mem rel_name relations method add_relation (rel : Relation.relation) = - {< relations = BatMap.String.add rel#name rel relations >} + {<relations = BatMap.String.add rel#name rel relations>} - method remove_relation rel_name = - {< relations = BatMap.String.remove rel_name relations >} + method remove_relation rel_name = {<relations = BatMap.String.remove rel_name relations>} method update_relation (rel : Relation.relation) = - if not (BatMap.String.mem rel#name relations) then {< >} - else {< relations = BatMap.String.add rel#name rel relations >} + if not (BatMap.String.mem rel#name relations) then {<>} + else {<relations = BatMap.String.add rel#name rel relations>} method serialize () : Storable.Multigroup.t = - { - Storable.Multigroup.name = name; - relations = BatMap.String.bindings relations |> List.map snd |> List.map (fun r -> r#serialize ()); - } -end + { Storable.Multigroup.name; + relations= + BatMap.String.bindings relations |> List.map snd |> List.map (fun r -> r#serialize ()) } + end let deserialize (bytes : bytes) : (multigroup, string) result = (* Reconstruct a multigroup from its persisted payload. @@ -48,19 +44,15 @@ let deserialize (bytes : bytes) : (multigroup, string) result = (fun mg rel -> let relation = new Relation.stored - ~name:rel.Storable.Relation.name - ~schema:rel.schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:None - ~provenance:None - ~membership_criteria:(fun _ -> true) + ~name:rel.Storable.Relation.name ~schema:rel.schema ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero ~lineage:None ~provenance:None + ~membership_criteria:(fun _ -> true ) in let relation = if rel.tree_pointer = "" then relation else relation#set_tree_pointer (Some rel.tree_pointer) in - mg#add_relation (relation :> Relation.relation)) + mg#add_relation (relation :> Relation.relation) ) db stored.relations in Ok db diff --git a/lib/management/physical.ml b/lib/management/physical.ml index 7c6f6b2..b896330 100644 --- a/lib/management/physical.ml +++ b/lib/management/physical.ml @@ -13,37 +13,35 @@ module type BACKEND = sig type connection - val connect : configuration -> (connection, Condition.t) result (** Connect to the storage backend *) + val connect : configuration -> (connection, Condition.t) result - val disconnect : connection -> unit (** Disconnect from the backend *) + val disconnect : connection -> unit - val get : connection -> Conventions.Hash.t -> (bytes option, Condition.t) result (** Get a value by its hash. Returns None if not found. *) + val get : connection -> Conventions.Hash.t -> (bytes option, Condition.t) result - val put : connection -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result (** Store a value at its hash *) + val put : connection -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result - val exists : connection -> Conventions.Hash.t -> (bool, Condition.t) result (** Check if a hash exists *) + val exists : connection -> Conventions.Hash.t -> (bool, Condition.t) result - val begin_transaction : connection -> (unit, Condition.t) result (** Begin a transaction *) + val begin_transaction : connection -> (unit, Condition.t) result - val commit : connection -> (unit, Condition.t) result (** Commit a transaction *) + val commit : connection -> (unit, Condition.t) result - val rollback : connection -> (unit, Condition.t) result (** Rollback a transaction *) + val rollback : connection -> (unit, Condition.t) result - val get_many : - connection -> Conventions.Hash.t list -> (bytes option list, Condition.t) result (** Batch get multiple values *) + val get_many : connection -> Conventions.Hash.t list -> (bytes option list, Condition.t) result - val put_many : - connection -> (Conventions.Hash.t * bytes) list -> (unit, Condition.t) result (** Batch put multiple values *) + val put_many : connection -> (Conventions.Hash.t * bytes) list -> (unit, Condition.t) result end (** Storage operations built on top of a backend *) @@ -52,38 +50,34 @@ module type S = sig type t - val create : configuration -> (t, Condition.t) result (** Create a storage instance from a backend connection *) + val create : configuration -> (t, Condition.t) result - val close : t -> unit (** Close the storage *) + val close : t -> unit - val store_attribute : - t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, Condition.t) result (** Store an attribute value, returns its hash *) + val store_attribute : t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, Condition.t) result - val load_attribute : - t -> - Conventions.Hash.t -> - (Conventions.AbstractValue.t option, Condition.t) result (** Load an attribute value by hash *) + val load_attribute : + t -> Conventions.Hash.t -> (Conventions.AbstractValue.t option, Condition.t) result - val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result (** Store raw bytes at a hash *) + val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result - val load_raw : t -> Conventions.Hash.t -> (bytes option, Condition.t) result (** Load raw bytes by hash *) + val load_raw : t -> Conventions.Hash.t -> (bytes option, Condition.t) result - val exists : t -> Conventions.Hash.t -> (bool, Condition.t) result (** Check if a hash exists *) + val exists : t -> Conventions.Hash.t -> (bool, Condition.t) result - val with_transaction : t -> (unit -> ('a, Condition.t) result) -> ('a, Condition.t) result (** Execute a function within a transaction *) + val with_transaction : t -> (unit -> ('a, Condition.t) result) -> ('a, Condition.t) result end (** Functor to create storage operations from a backend *) -module Make (B : BACKEND) : - S with type configuration = B.configuration = struct +module Make (B : BACKEND) : S with type configuration = B.configuration = struct type configuration = B.configuration type t = B.connection @@ -110,30 +104,31 @@ module Make (B : BACKEND) : match B.begin_transaction conn with | Error e -> Error e | Ok () -> ( - match f () with - | Ok result -> ( - match B.commit conn with Ok () -> Ok result | Error e -> Error e) - | Error e -> - let _ = B.rollback conn in - Error e) + match f () with + | Ok result -> ( match B.commit conn with Ok () -> Ok result | Error e -> Error e ) + | Error e -> + let _ = B.rollback conn in + Error e ) end (** In-memory backend for testing and development *) -module MemoryBackend : - BACKEND with type configuration = unit = struct +module MemoryBackend : BACKEND with type configuration = unit = struct type configuration = unit - type connection = { - data : (string, bytes) Hashtbl.t; - mutable in_transaction : bool; - mutable transaction_buffer : (string * bytes) list; - } + type connection = + { data: (string, bytes) Hashtbl.t; + mutable in_transaction: bool; + mutable transaction_buffer: (string * bytes) list } module Error = struct open Condition + (* TODO: more structure *) let parse_error msg = condition "parse-error" msg empty - let already_in_transaction = condition "already-in-transaction" "Already inside a transaction" empty + + let already_in_transaction = + condition "already-in-transaction" "Already inside a transaction" empty + let not_in_transaction = condition "not-in-transaction" "Not inside a transaction" empty end @@ -144,16 +139,9 @@ module MemoryBackend : Error (Error.parse_error (Printf.sprintf "memory backend takes no configuration, got: %s" - (Sexplib.Sexp.to_string sexp))) - - let connect () = - Ok - { - data = Hashtbl.create 1024; - in_transaction = false; - transaction_buffer = []; - } + (Sexplib.Sexp.to_string sexp) ) ) + let connect () = Ok {data= Hashtbl.create 1024; in_transaction= false; transaction_buffer= []} let disconnect _ = () let get conn hash = Ok (Hashtbl.find_opt conn.data hash) @@ -180,9 +168,7 @@ module MemoryBackend : let commit conn = if not conn.in_transaction then Error Error.not_in_transaction else begin - List.iter - (fun (hash, value) -> Hashtbl.replace conn.data hash value) - conn.transaction_buffer; + List.iter (fun (hash, value) -> Hashtbl.replace conn.data hash value) conn.transaction_buffer; conn.in_transaction <- false; conn.transaction_buffer <- []; Ok () @@ -196,18 +182,17 @@ module MemoryBackend : Ok () end - let get_many conn hashes = - Ok (List.map (fun h -> Hashtbl.find_opt conn.data h) hashes) + let get_many conn hashes = Ok (List.map (fun h -> Hashtbl.find_opt conn.data h) hashes) let put_many conn pairs = List.iter (fun (hash, value) -> if conn.in_transaction then conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer - else Hashtbl.replace conn.data hash value) + else Hashtbl.replace conn.data hash value ) pairs; Ok () end -module Memory = Make (MemoryBackend) (** Default in-memory storage for development *) +module Memory = Make (MemoryBackend) diff --git a/lib/manipulation.ml b/lib/manipulation.ml index e62af28..2b7a421 100644 --- a/lib/manipulation.ml +++ b/lib/manipulation.ml @@ -21,8 +21,7 @@ module Make (Storage : Management.Physical.S) = struct open Condition (* TODO: more specific errors *) - let storage_error message = - condition "storage-error" message empty + let storage_error message = condition "storage-error" message empty end let ( let* ) = Result.bind @@ -30,27 +29,25 @@ module Make (Storage : Management.Physical.S) = struct (* State Persistence - Store relation and database states *) (** Store a relation state to storage *) - let store_relation (storage : storage) (relation : Relation.relation) : - (unit, error) Result.t = - match - Storage.store_raw storage relation#hash (Storable.Relation.to_bytes @@ relation#serialize ()) - with - | Error _ -> Error (Error.storage_error "Failed to store relation") - | Ok () -> Ok () + let store_relation (storage : storage) (relation : Relation.relation) : (unit, error) Result.t = + match + Storage.store_raw storage relation#hash (Storable.Relation.to_bytes @@ relation#serialize ()) + with + | Error _ -> Error (Error.storage_error "Failed to store relation") + | Ok () -> Ok () - (** Store a database state to storage. - Keyed by [db#name]; content-hashing of mgs is no longer maintained on the - Sakura side — the kernel owns mg content addressing. *) + (** Store a database state to storage. Keyed by [db#name]; content-hashing of + mgs is no longer maintained on the Sakura side — the kernel owns mg + content addressing. *) let store_multigroup (storage : storage) (db : Management.Multigroup.multigroup) : (unit, error) Result.t = - match - Storage.store_raw storage db#name (Storable.Multigroup.to_bytes @@ db#serialize ()) - with - | Error _ -> Error (Error.storage_error "Failed to store multigroup") - | Ok () -> Ok () + match Storage.store_raw storage db#name (Storable.Multigroup.to_bytes @@ db#serialize ()) with + | Error _ -> Error (Error.storage_error "Failed to store multigroup") + | Ok () -> Ok () (** Load a relation state from storage by hash *) - let load_relation (storage : storage) (rel_hash : Conventions.Hash.t) : (Relation.stored option, error) Result.t = + let load_relation (storage : storage) (rel_hash : Conventions.Hash.t) : + (Relation.stored option, error) Result.t = match Storage.load_raw storage rel_hash with | Error _ -> Error (Error.storage_error "Failed to load relation") | Ok None -> Ok None @@ -63,12 +60,7 @@ module Make (Storage : Management.Physical.S) = struct let membership_criteria = Constraint.build_membership_criteria ~_name:name ~schema in let relation = new Relation.stored - ~name - ~schema - ~constraints - ~cardinality - ~membership_criteria - ~provenance:None + ~name ~schema ~constraints ~cardinality ~membership_criteria ~provenance:None ~lineage:None in Ok (Some relation) @@ -89,7 +81,8 @@ module Make (Storage : Management.Physical.S) = struct (** Store each attribute value and return map of attr_name -> attr_hash *) let store_attributes (_storage : storage) (_tuple : Tuple.materialized) : - ((string * Conventions.Hash.t) list, error) Result.t = failwith "NOT IMPLEMENTED" + ((string * Conventions.Hash.t) list, error) Result.t = + failwith "NOT IMPLEMENTED" (** Load a tuple from storage by its hash *) let load_tuple (storage : storage) (tuple_hash : Conventions.Hash.t) : @@ -104,22 +97,18 @@ module Make (Storage : Management.Physical.S) = struct let rec load_attrs acc = function | [] -> Ok (List.rev acc) | (name, attr_hash) :: rest -> ( - match Storage.load_raw storage attr_hash with - | Error _ -> - Error - (Error.storage_error ("Failed to load attribute: " ^ name)) - | Ok None -> - Error (Error.storage_error ("Attribute not found: " ^ name)) - | Ok (Some value_bytes) -> - let value : Conventions.AbstractValue.t = - Marshal.from_bytes value_bytes 0 - in - let attr : Attribute.materialized = { value } in - load_attrs ((name, attr) :: acc) rest) + match Storage.load_raw storage attr_hash with + | Error _ -> Error (Error.storage_error ("Failed to load attribute: " ^ name)) + | Ok None -> Error (Error.storage_error ("Attribute not found: " ^ name)) + | Ok (Some value_bytes) -> + let value : Conventions.AbstractValue.t = Marshal.from_bytes value_bytes 0 in + let attr : Attribute.materialized = {value} in + load_attrs ((name, attr) :: acc) rest ) in load_attrs [] attributes - |> Result.map (List.fold_left - (fun m (k, v) -> Tuple.AttributeMap.add k v m) - Tuple.AttributeMap.empty) - |> Result.map (fun attributes -> Some { Tuple.relation = relation; attributes }) + |> Result.map + (List.fold_left + (fun m (k, v) -> Tuple.AttributeMap.add k v m) + Tuple.AttributeMap.empty ) + |> Result.map (fun attributes -> Some {Tuple.relation; attributes}) end @@ -19,30 +19,29 @@ type relation_handle = nativeint type cursor_kind = Simple | Vm (** A streaming cursor over tuples produced either by a simple scan or the VM. *) -type tuple_stream = { - ts_cursor : nativeint; - ts_relation : string; - ts_kind : cursor_kind; -} +type tuple_stream = {ts_cursor: nativeint; ts_relation: string; ts_kind: cursor_kind} type path_arg = Var of string | Const of string type plan_node = - | Scan of { path : string; args : (string * path_arg) list } + | Scan of {path: string; args: (string * path_arg) list} (* Given this is the query plan, this should probably specify a concrete join algorithm (e.g. HashJoin, NestedLoop, LeapFrog, &c) *) - | Join of { left : plan_node; right : plan_node; on_attrs : string list } - | Take of { limit : int; source : plan_node } - | Project of { attrs : string list; source : plan_node } + | Join of {left: plan_node; right: plan_node; on_attrs: string list} + | Take of {limit: int; source: plan_node} + | Project of {attrs: string list; source: plan_node} module Error = struct open Condition + (* TODO: better error structure *) let auth_failed msg = condition "auth-failed" msg empty - let handle_error rc msg = condition "handle-error" msg ("return-code" |=| (of_int rc)) - let object_not_found kind id = condition "object-not-found" "Object not found" - ("kind" |=| (of_string kind) & - "identifier" |=| (of_string id)) + let handle_error rc msg = condition "handle-error" msg ("return-code" |=| of_int rc) + + let object_not_found kind id = + condition "object-not-found" "Object not found" + ("kind" |=| of_string kind & "identifier" |=| of_string id) + let cursor_error msg = condition "cursor-error" msg empty let not_supported msg = condition "not-supported" msg empty let initialization_error = condition "initialization-error" "Couldn't initialize" empty @@ -53,9 +52,10 @@ end -------------------------------------------------------------------------- *) module type Backend = sig - (** RNT storage driver: "sqlite" or "memory". *) - val driver : string - (** Passed to the driver as its init argument. + (* RNT storage driver: "sqlite" or "memory". *) + val driver : string + + (* Passed to the driver as its init argument. For "sqlite": file path or ":memory:". For "memory": ignored. *) val init_arg : string @@ -66,7 +66,6 @@ end -------------------------------------------------------------------------- *) module Make (B : Backend) = struct - let ( let* ) = Result.bind (* -------------------------------------------------------------------------- @@ -74,30 +73,25 @@ module Make (B : Backend) = struct -------------------------------------------------------------------------- *) let authenticate (method_ : auth_method) : (claims, Condition.t) result = - let method_str = match method_ with - | Certificate -> "certificate" - | PlainText -> "plain_text" + let method_str = + match method_ with Certificate -> "certificate" | PlainText -> "plain_text" in - let (rc, claims_opt) = - Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_firewall method_str pp) - in - match (rc, claims_opt) with - | (0, Some s) -> Ok s - | (_, Some s) -> Error (Error.auth_failed s) - | _ -> Error (Error.auth_failed "firewall rejected connection") + let rc, claims_opt = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_firewall method_str pp) in + match rc, claims_opt with + | 0, Some s -> Ok s + | _, Some s -> Error (Error.auth_failed s) + | _ -> Error (Error.auth_failed "firewall rejected connection") (* -------------------------------------------------------------------------- Path helpers (shared by branch and relation lifecycle) -------------------------------------------------------------------------- *) - let branch_path (branch_name : string) : string = - "/system/branches/" ^ branch_name + let branch_path (branch_name : string) : string = "/system/branches/" ^ branch_name let multigroup_path ~(branch_name : string) ~(mg_name : string) : string = branch_path branch_name ^ "/multigroups/" ^ mg_name - let relation_path ~(branch_name : string) ~(mg_name : string) - ~(rel_name : string) : string = + let relation_path ~(branch_name : string) ~(mg_name : string) ~(rel_name : string) : string = multigroup_path ~branch_name ~mg_name ^ "/relations/" ^ rel_name (* -------------------------------------------------------------------------- @@ -115,72 +109,64 @@ module Make (B : Backend) = struct ignore (Nt_ffi.rnt_register_branch path "") let branch_target_of_handle (bh : branch_handle) : (string, Condition.t) result = - let (rc, target_opt) = - Nt_ffi.with_out_string - (fun pp -> Nt_ffi.rnt_branch_target (Nt_ffi.nint_to_ptr bh) pp) + let rc, target_opt = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_branch_target (Nt_ffi.nint_to_ptr bh) pp) in - match (rc, target_opt) with - | (0, Some s) -> Ok s - | (0, None) -> Ok "" - | _ -> Error (Error.handle_error rc "branch_target read failed") + match rc, target_opt with + | 0, Some s -> Ok s + | 0, None -> Ok "" + | _ -> Error (Error.handle_error rc "branch_target read failed") let list_relations ~(branch_name : string) ~(mg_name : string) : ((string * string) list, Condition.t) result = let path = multigroup_path ~branch_name ~mg_name in - let (rc, out_opt) = - Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_relations path pp) - in - match (rc, out_opt) with - | (0, Some s) -> + let rc, out_opt = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_relations path pp) in + match rc, out_opt with + | 0, Some s -> let pairs = String.split_on_char '\n' s |> List.filter_map (fun line -> match String.split_on_char '\t' line with | [n; r] when n <> "" -> Some (n, r) - | _ -> None) + | _ -> None ) in Ok pairs - | (0, None) -> Ok [] - | _ -> Error (Error.handle_error rc - ("list_relations failed: " ^ branch_name - ^ "/" ^ mg_name)) + | 0, None -> Ok [] + | _ -> Error (Error.handle_error rc ("list_relations failed: " ^ branch_name ^ "/" ^ mg_name)) - let list_branch_multigroups (branch_name : string) : - ((string * string) list, Condition.t) result = + let list_branch_multigroups (branch_name : string) : ((string * string) list, Condition.t) result + = let path = branch_path branch_name in - let (rc, out_opt) = - Nt_ffi.with_out_string - (fun pp -> Nt_ffi.rnt_list_branch_multigroups path pp) + let rc, out_opt = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_branch_multigroups path pp) in - match (rc, out_opt) with - | (0, Some s) -> + match rc, out_opt with + | 0, Some s -> let pairs = String.split_on_char '\n' s |> List.filter_map (fun line -> match String.split_on_char '\t' line with | [n; h] when n <> "" -> Some (n, h) - | _ -> None) + | _ -> None ) in Ok pairs - | (0, None) -> Ok [] - | _ -> Error (Error.handle_error rc - ("list_branch_multigroups failed: " ^ branch_name)) + | 0, None -> Ok [] + | _ -> Error (Error.handle_error rc ("list_branch_multigroups failed: " ^ branch_name)) let session_open () : (string, Condition.t) result = - let (rc, id_opt) = - Nt_ffi.with_out_string - (fun pp -> Nt_ffi.rnt_session_open (from_voidp void null) pp) + let rc, id_opt = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_session_open (from_voidp void null) pp) in - match (rc, id_opt) with - | (0, Some id) -> Ok id - | _ -> Error (Error.handle_error rc "session_open failed") + match rc, id_opt with + | 0, Some id -> Ok id + | _ -> Error (Error.handle_error rc "session_open failed") let session_close (sid : string) : (unit, Condition.t) result = let rc = Nt_ffi.rnt_session_close sid in if rc = 0 then Ok () else Error (Error.handle_error rc "session_close failed") - let session_set_branch (sid : string) (branch_name : string) - (target_hash : string) : (unit, Condition.t) result = + let session_set_branch (sid : string) (branch_name : string) (target_hash : string) : + (unit, Condition.t) result = let rc = Nt_ffi.rnt_session_set_branch sid branch_name target_hash in if rc = 0 then Ok () else Error (Error.handle_error rc "session_set_branch failed") @@ -192,8 +178,8 @@ module Make (B : Backend) = struct match Nt_ffi.ptr_to_opt raw with | None -> Error (Error.object_not_found "branch" name) | Some bh -> - let* _tip = branch_target_of_handle bh in - let* rel_entries = list_relations ~branch_name:name ~mg_name:name in + let* _tip = branch_target_of_handle bh in + let* rel_entries = list_relations ~branch_name:name ~mg_name:name in (* Populate mg with stored relations from RNT snapshot. Schema is not persisted in the snapshot codec so relations start schema-less; the session rebuilds schema state via DDL or catalog queries. *) @@ -202,17 +188,15 @@ module Make (B : Backend) = struct (fun mg (rel_name, root) -> let rel = (new Relation.stored - ~name:rel_name - ~schema:[] - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:(Some (Relation.Lineage.Base rel_name)) - ~provenance:(Some (Relation.Provenance.base - ~relation:rel_name ~attributes:[])) - ~membership_criteria:(fun _ -> true)) - #set_tree_pointer (Some root) + ~name:rel_name ~schema:[] ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base rel_name)) + ~provenance:(Some (Relation.Provenance.base ~relation:rel_name ~attributes:[])) + ~membership_criteria:(fun _ -> true) ) + #set_tree_pointer + (Some root) in - mg#add_relation (rel :> Relation.relation)) + mg#add_relation (rel :> Relation.relation) ) (new Management.Multigroup.multigroup ~name) rel_entries in @@ -224,29 +208,27 @@ module Make (B : Backend) = struct let list_snapshot_relations (snapshot_hash : string) : ((string * string) list, Condition.t) result = - let (rc, out_opt) = - Nt_ffi.with_out_string - (fun pp -> Nt_ffi.rnt_list_snapshot_relations snapshot_hash pp) + let rc, out_opt = + Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_list_snapshot_relations snapshot_hash pp) in - match (rc, out_opt) with - | (0, Some s) -> + match rc, out_opt with + | 0, Some s -> let pairs = String.split_on_char '\n' s |> List.filter_map (fun line -> match String.split_on_char '\t' line with | [n; r] when n <> "" -> Some (n, r) - | _ -> None) + | _ -> None ) in Ok pairs - | (0, None) -> Ok [] - | _ -> Error (Error.handle_error rc ("list_snapshot_relations failed: " ^ snapshot_hash)) + | 0, None -> Ok [] + | _ -> Error (Error.handle_error rc ("list_snapshot_relations failed: " ^ snapshot_hash)) (* Opens a read-only view pinned to a specific snapshot hash. Returns (bh, mg) where bh is a handle on the snapshot object and mg reflects exactly the relation set at that hash. The caller is responsible for refusing mutations (see Branch.Detached). *) - let open_snapshot (_claims : claims) (branch_name : string) - (snapshot_hash : string) : + let open_snapshot (_claims : claims) (branch_name : string) (snapshot_hash : string) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let snap_path = "/system/snapshots/" ^ snapshot_hash in let raw = Nt_ffi.rnt_open_handle snap_path (from_voidp void null) in @@ -259,17 +241,15 @@ module Make (B : Backend) = struct (fun mg (rel_name, root) -> let rel = (new Relation.stored - ~name:rel_name - ~schema:[] - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:(Some (Relation.Lineage.Base rel_name)) - ~provenance:(Some (Relation.Provenance.base - ~relation:rel_name ~attributes:[])) - ~membership_criteria:(fun _ -> true)) - #set_tree_pointer (Some root) + ~name:rel_name ~schema:[] ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base rel_name)) + ~provenance:(Some (Relation.Provenance.base ~relation:rel_name ~attributes:[])) + ~membership_criteria:(fun _ -> true) ) + #set_tree_pointer + (Some root) in - mg#add_relation (rel :> Relation.relation)) + mg#add_relation (rel :> Relation.relation) ) (new Management.Multigroup.multigroup ~name:branch_name) rel_entries in @@ -279,8 +259,8 @@ module Make (B : Backend) = struct Relation handles -------------------------------------------------------------------------- *) - let open_relation ~(branch_name : string) ~(mg_name : string) - ~(rel_name : string) : (relation_handle, Condition.t) result = + let open_relation ~(branch_name : string) ~(mg_name : string) ~(rel_name : string) : + (relation_handle, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in ignore (Nt_ffi.rnt_register_relation path); let raw = Nt_ffi.rnt_open_handle path (from_voidp void null) in @@ -307,7 +287,7 @@ module Make (B : Backend) = struct let rec build_plan (plan : plan_node) : (nativeint, Condition.t) result = match plan with - | Scan { path; _ } -> + | Scan {path; _} -> ( let act = make_action Nt_ffi.fol_operation_scan in let cpath = Nt_ffi.cstring path in let scan = getf act Nt_ffi.action_scan in @@ -315,35 +295,35 @@ module Make (B : Backend) = struct let raw = Nt_ffi.rnt_plan_assemble act in (* keep the C string alive across the call above *) ignore (Sys.opaque_identity cpath); - (match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.cursor_error ("plan_scan failed for path: " ^ path)) - | Some p -> Ok p) - | Join { left; right; _ } -> + match Nt_ffi.ptr_to_opt raw with + | None -> Error (Error.cursor_error ("plan_scan failed for path: " ^ path)) + | Some p -> Ok p ) + | Join {left; right; _} -> ( let* lp = build_plan left in - (match build_plan right with - | Error e -> - Nt_ffi.rnt_plan_free (Nt_ffi.nint_to_ptr lp); - Error e - | Ok rp -> - let act = make_action Nt_ffi.fol_operation_join in - let join = getf act Nt_ffi.action_join in - setf join Nt_ffi.join_left (Nt_ffi.nint_to_ptr lp); - setf join Nt_ffi.join_right (Nt_ffi.nint_to_ptr rp); - (* assemble takes ownership of both children *) - (match Nt_ffi.ptr_to_opt (Nt_ffi.rnt_plan_assemble act) with - | None -> Error (Error.cursor_error "plan_join failed") - | Some p -> Ok p)) - | Take { limit; source } -> + match build_plan right with + | Error e -> + Nt_ffi.rnt_plan_free (Nt_ffi.nint_to_ptr lp); + Error e + | Ok rp -> ( + let act = make_action Nt_ffi.fol_operation_join in + let join = getf act Nt_ffi.action_join in + setf join Nt_ffi.join_left (Nt_ffi.nint_to_ptr lp); + setf join Nt_ffi.join_right (Nt_ffi.nint_to_ptr rp); + (* assemble takes ownership of both children *) + match Nt_ffi.ptr_to_opt (Nt_ffi.rnt_plan_assemble act) with + | None -> Error (Error.cursor_error "plan_join failed") + | Some p -> Ok p ) ) + | Take {limit; source} -> ( let* sp = build_plan source in let act = make_action Nt_ffi.fol_operation_take in let take = getf act Nt_ffi.action_take in setf take Nt_ffi.take_source (Nt_ffi.nint_to_ptr sp); setf take Nt_ffi.take_limit (Unsigned.Size_t.of_int limit); (* assemble takes ownership of source *) - (match Nt_ffi.ptr_to_opt (Nt_ffi.rnt_plan_assemble act) with - | None -> Error (Error.cursor_error "plan_take failed") - | Some p -> Ok p) - | Project { attrs; source } -> + match Nt_ffi.ptr_to_opt (Nt_ffi.rnt_plan_assemble act) with + | None -> Error (Error.cursor_error "plan_take failed") + | Some p -> Ok p ) + | Project {attrs; source} -> ( let* sp = build_plan source in let act = make_action Nt_ffi.fol_operation_project in let proj = getf act Nt_ffi.action_project in @@ -353,23 +333,21 @@ module Make (B : Backend) = struct let cattrs = List.map Nt_ffi.cstring attrs in let arr = Ctypes.CArray.of_list (Ctypes.ptr Ctypes.char) - (List.map Ctypes.CArray.start cattrs - @ [ Nt_ffi.null_char_ptr ]) + (List.map Ctypes.CArray.start cattrs @ [Nt_ffi.null_char_ptr]) in setf proj Nt_ffi.project_attrs (Ctypes.CArray.start arr); let raw = Nt_ffi.rnt_plan_assemble act in ignore (Sys.opaque_identity (cattrs, arr)); - (match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.cursor_error "plan_project failed") - | Some p -> Ok p) + match Nt_ffi.ptr_to_opt raw with + | None -> Error (Error.cursor_error "plan_project failed") + | Some p -> Ok p ) - let execute_query (plan : plan_node) ~(rel_name : string) : - (tuple_stream, Condition.t) result = + let execute_query (plan : plan_node) ~(rel_name : string) : (tuple_stream, Condition.t) result = let* plan_ptr = build_plan plan in let raw = Nt_ffi.rnt_vm_execute_plan (Nt_ffi.nint_to_ptr plan_ptr) in match Nt_ffi.ptr_to_opt raw with - | None -> Error (Error.cursor_error "vm_execute_plan failed") - | Some ts_cursor -> Ok { ts_cursor; ts_relation = rel_name; ts_kind = Vm } + | None -> Error (Error.cursor_error "vm_execute_plan failed") + | Some ts_cursor -> Ok {ts_cursor; ts_relation= rel_name; ts_kind= Vm} let parse_kv_tuple (relation : string) (kv : string) : Tuple.materialized = let attributes = @@ -378,35 +356,32 @@ module Make (B : Backend) = struct match String.split_on_char '=' line with | k :: rest when k <> "" -> let v = String.concat "=" rest in - Some (k, Attribute.{ value = Obj.repr v }) - | _ -> None) - |> List.fold_left - (fun m (k, v) -> Tuple.AttributeMap.add k v m) - Tuple.AttributeMap.empty + Some (k, Attribute.{value= Obj.repr v}) + | _ -> None ) + |> List.fold_left (fun m (k, v) -> Tuple.AttributeMap.add k v m) Tuple.AttributeMap.empty in - { Tuple.relation; attributes } + {Tuple.relation; attributes} - let stream_next (stream : tuple_stream) : - (Tuple.materialized option, Condition.t) result = - let next_fn = match stream.ts_kind with - | Simple -> Nt_ffi.rnt_cursor_next - | Vm -> Nt_ffi.rnt_vm_cursor_next + let stream_next (stream : tuple_stream) : (Tuple.materialized option, Condition.t) result = + let next_fn = + match stream.ts_kind with Simple -> Nt_ffi.rnt_cursor_next | Vm -> Nt_ffi.rnt_vm_cursor_next in - let (rc, kv_opt) = - Nt_ffi.with_out_string - (fun pp -> next_fn (Nt_ffi.nint_to_ptr stream.ts_cursor) pp) + let rc, kv_opt = + Nt_ffi.with_out_string (fun pp -> next_fn (Nt_ffi.nint_to_ptr stream.ts_cursor) pp) in match rc with | 0 -> Ok None - | 1 -> (match kv_opt with - | None -> Ok None - | Some kv -> Ok (Some (parse_kv_tuple stream.ts_relation kv))) + | 1 -> ( + match kv_opt with + | None -> Ok None + | Some kv -> Ok (Some (parse_kv_tuple stream.ts_relation kv)) ) | _ -> Error (Error.cursor_error "cursor_next error") let stream_close (stream : tuple_stream) : (unit, Condition.t) result = - let close_fn = match stream.ts_kind with + let close_fn = + match stream.ts_kind with | Simple -> Nt_ffi.rnt_cursor_close - | Vm -> Nt_ffi.rnt_vm_cursor_close + | Vm -> Nt_ffi.rnt_vm_cursor_close in let rc = close_fn (Nt_ffi.nint_to_ptr stream.ts_cursor) in if rc = 0 then Ok () else Error (Error.cursor_error "cursor_close failed") @@ -431,70 +406,62 @@ module Make (B : Backend) = struct accepted cost of this slice) -------------------------------------------------------------------------- *) - let retained_generators - : (string, - unit Ctypes.ptr -> string -> Unsigned.size_t -> Unsigned.size_t -> - unit Ctypes.ptr -> int) - Hashtbl.t = + let retained_generators : + ( string, + unit Ctypes.ptr -> string -> Unsigned.size_t -> Unsigned.size_t -> unit Ctypes.ptr -> int + ) + Hashtbl.t = Hashtbl.create 16 let register_ephemeral ~(session : string) ~(named : bool) ~(name : string) ~(generator : offset:int -> limit:int -> Tuple.materialized list) - ~(cardinality : Conventions.Cardinality.t) ~(identity : string) - ~(schema : Schema.t) ~(deps : string list) : (string, Condition.t) result = + ~(cardinality : Conventions.Cardinality.t) ~(identity : string) ~(schema : Schema.t) + ~(deps : string list) : (string, Condition.t) result = (* The callback re-enters the RNT API (the generator typically executes a VM plan over the base relations); the runtime is single threaded, so this is safe. Exceptions must not cross the FFI boundary! *) let cb _ctx _args offset limit sink = try let tuples = - generator - ~offset:(Unsigned.Size_t.to_int offset) - ~limit:(Unsigned.Size_t.to_int limit) + generator ~offset:(Unsigned.Size_t.to_int offset) ~limit:(Unsigned.Size_t.to_int limit) in List.iter (fun t -> let kv = - materialized_to_kv t - |> List.map (fun (k, v) -> k ^ "=" ^ v) - |> String.concat "\n" + materialized_to_kv t |> List.map (fun (k, v) -> k ^ "=" ^ v) |> String.concat "\n" in - ignore (Nt_ffi.rnt_sink_emit sink (kv ^ "\n"))) + ignore (Nt_ffi.rnt_sink_emit sink (kv ^ "\n")) ) tuples; 0 with _ -> -1 in - let schema_kv = - schema |> List.map (fun (n, d) -> n ^ "=" ^ d) |> String.concat "\n" - in + let schema_kv = schema |> List.map (fun (n, d) -> n ^ "=" ^ d) |> String.concat "\n" in let card = match cardinality with - | Conventions.Cardinality.Finite _ -> 0 + | Conventions.Cardinality.Finite _ -> 0 | Conventions.Cardinality.ConstrainedFinite -> 1 - | Conventions.Cardinality.AlephZero -> 2 - | Conventions.Cardinality.Continuum -> 3 + | Conventions.Cardinality.AlephZero -> 2 + | Conventions.Cardinality.Continuum -> 3 in - let (rc, path_opt) = + let rc, path_opt = Nt_ffi.with_out_string (fun pp -> - Nt_ffi.rnt_register_ephemeral_relation session - (if named then 1 else 0) name cb (from_voidp void null) card - identity schema_kv (String.concat "\n" deps) pp) + Nt_ffi.rnt_register_ephemeral_relation session + (if named then 1 else 0) + name cb (from_voidp void null) card identity schema_kv (String.concat "\n" deps) pp ) in - match (rc, path_opt) with - | (0, Some path) -> + match rc, path_opt with + | 0, Some path -> Hashtbl.replace retained_generators path cb; Ok path - | (rc, _) -> Error (Error.handle_error rc ("register_ephemeral failed: " ^ name)) + | rc, _ -> Error (Error.handle_error rc ("register_ephemeral failed: " ^ name)) - let drop_ephemeral ~(session : string) ~(name : string) : - (unit, Condition.t) result = + let drop_ephemeral ~(session : string) ~(name : string) : (unit, Condition.t) result = (* TODO: we leak the retained closure here. We can rebuild the path from session + name (same formula as Sublanguage_context.ephemeral_path) and Hashtbl.remove it, instead of holding onto one closure per dropped view until a later re-registration overwrites it. *) let rc = Nt_ffi.rnt_drop_ephemeral_relation session name in - if rc = 0 then Ok () - else Error (Error.handle_error rc ("drop_ephemeral failed: " ^ name)) + if rc = 0 then Ok () else Error (Error.handle_error rc ("drop_ephemeral failed: " ^ name)) (* -------------------------------------------------------------------------- Multigroup / branch mutations @@ -514,31 +481,28 @@ module Make (B : Backend) = struct (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let mg_name = mg#name in let path = relation_path ~branch_name ~mg_name ~rel_name:name in - let rc = Nt_ffi.rnt_register_relation path in + let rc = Nt_ffi.rnt_register_relation path in if rc <> 0 then Error (Error.handle_error rc ("register_relation failed: " ^ name)) else let rel_root = - let (rc, opt) = - Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) - in + let rc, opt = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) in if rc = 0 then Option.value opt ~default:"" else "" in - let rel = (new Relation.stored - ~name - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:(Some (Relation.Lineage.Base name)) - ~provenance:(Some (Relation.Provenance.base ~relation:name - ~attributes:(List.map fst schema))) - ~membership_criteria:(fun _ -> true))#set_tree_pointer (Some rel_root) + let rel = + (new Relation.stored + ~name ~schema ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero + ~lineage:(Some (Relation.Lineage.Base name)) + ~provenance: + (Some (Relation.Provenance.base ~relation:name ~attributes:(List.map fst schema))) + ~membership_criteria:(fun _ -> true) ) + #set_tree_pointer + (Some rel_root) in let* _tip = branch_target_of_handle bh in Ok (bh, mg#add_relation (rel :> Relation.relation)) - let retract_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) - ~(name : string) : - (branch_handle * Management.Multigroup.multigroup, Condition.t) result = + let retract_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) ~(name : string) + : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = (* TODO: there is no rnt_unregister_relation today; the OCaml mg drops the relation but RNT continues to carry it in the current snapshot. This drifts the two views — fine while the in-memory mg is the source of @@ -547,8 +511,7 @@ module Make (B : Backend) = struct Ok (bh, mg#remove_relation name) let clear_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) - ~(branch_name : string) ~(mg_name : string) - (rel : Relation.relation) : + ~(branch_name : string) ~(mg_name : string) (rel : Relation.relation) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name:rel#name in let rc = Nt_ffi.rnt_clear_relation path in @@ -562,42 +525,39 @@ module Make (B : Backend) = struct (branch_handle * Management.Multigroup.multigroup, Condition.t) result = Ok (_bh, mg#add_relation (domain :> Relation.relation)) - let create_immutable_relation (bh : branch_handle) - (mg : Management.Multigroup.multigroup) ~name ~schema ~generator - ~membership_criteria ~cardinality ~(producer : Relation.producer option) : + let create_immutable_relation (bh : branch_handle) (mg : Management.Multigroup.multigroup) ~name + ~schema ~generator ~membership_criteria ~cardinality ~(producer : Relation.producer option) : (branch_handle * Management.Multigroup.multigroup * Relation.relation, Condition.t) result = let rel : Relation.relation = match producer with | Some p -> - (new Relation.pseudo ~name ~schema ~constraints:None ~cardinality - ~membership_criteria ~lineage:None - ~provenance:Relation.Provenance.empty ~producer:p - :> Relation.relation) + ( new Relation.pseudo + ~name ~schema ~constraints:None ~cardinality ~membership_criteria ~lineage:None + ~provenance:Relation.Provenance.empty ~producer:p + :> Relation.relation ) | None -> - (new Relation.ephemeral ~name ~schema ~constraints:None ~cardinality - ~membership_criteria ~lineage:None ~provenance:None ~generator - :> Relation.relation) + ( new Relation.ephemeral + ~name ~schema ~constraints:None ~cardinality ~membership_criteria ~lineage:None + ~provenance:None ~generator + :> Relation.relation ) in Ok (bh, mg#add_relation rel, rel) - let register_constraint (bh : branch_handle) - (mg : Management.Multigroup.multigroup) ~constraint_name ~relation_name - ~(body : Constraint.t) : + let register_constraint (bh : branch_handle) (mg : Management.Multigroup.multigroup) + ~constraint_name ~relation_name ~(body : Constraint.t) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = match mg#get_relation relation_name with | None -> Error (Error.object_not_found "relation" relation_name) | Some rel -> - let existing = - match rel#constraints with Some cs -> cs | None -> [] - in + let existing = match rel#constraints with Some cs -> cs | None -> [] in let new_constraints = (constraint_name, body) :: existing in let updated_rel = - (Obj.magic rel - : < set_constraints : + ( Obj.magic rel + : < set_constraints: Relation.RelationConstraint.t -> - < constraints : Relation.RelationConstraint.t option - ; .. > >) - #set_constraints new_constraints + < constraints: Relation.RelationConstraint.t option ; .. > > ) + #set_constraints + new_constraints in Ok (bh, mg#update_relation (updated_rel :> Relation.relation)) @@ -605,48 +565,41 @@ module Make (B : Backend) = struct Tuple mutations -------------------------------------------------------------------------- *) - let insert_tuple ~(branch_name : string) ~(mg_name : string) - ~(rel_name : string) (attrs : (string * string) list) : - (string, Condition.t) result = - let path = relation_path ~branch_name ~mg_name ~rel_name in - let kv_str = List.map (fun (k, v) -> k ^ "=" ^ v ^ "\n") attrs - |> String.concat "" in - let (rc, hash_opt) = - Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_link_tuple path kv_str pp) - in - match (rc, hash_opt) with - | (0, Some h) -> Ok h - | _ -> Error (Error.handle_error rc "insert_tuple failed") + let insert_tuple ~(branch_name : string) ~(mg_name : string) ~(rel_name : string) + (attrs : (string * string) list) : (string, Condition.t) result = + let path = relation_path ~branch_name ~mg_name ~rel_name in + let kv_str = List.map (fun (k, v) -> k ^ "=" ^ v ^ "\n") attrs |> String.concat "" in + let rc, hash_opt = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_link_tuple path kv_str pp) in + match rc, hash_opt with + | 0, Some h -> Ok h + | _ -> Error (Error.handle_error rc "insert_tuple failed") let create_tuple ~branch_name ~mg_name ~rel_name (tuple : Tuple.materialized) : (string, Condition.t) result = insert_tuple ~branch_name ~mg_name ~rel_name (materialized_to_kv tuple) - let create_tuples ~branch_name ~mg_name ~rel_name - (tuples : Tuple.materialized list) : (string, Condition.t) result = + let create_tuples ~branch_name ~mg_name ~rel_name (tuples : Tuple.materialized list) : + (string, Condition.t) result = List.fold_left (fun acc t -> let* _ = acc in let* h = create_tuple ~branch_name ~mg_name ~rel_name t in - Ok h) + Ok h ) (Ok "") tuples - let retract_tuple ~branch_name ~mg_name ~rel_name (hash : string) : - (unit, Condition.t) result = + let retract_tuple ~branch_name ~mg_name ~rel_name (hash : string) : (unit, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in let rc = Nt_ffi.rnt_unlink_tuple path hash in if rc = 0 then Ok () else Error (Error.handle_error rc "retract_tuple failed") - let relation_root ~(branch_name : string) ~(mg_name : string) - ~(rel_name : string) : (string, Condition.t) result = + let relation_root ~(branch_name : string) ~(mg_name : string) ~(rel_name : string) : + (string, Condition.t) result = let path = relation_path ~branch_name ~mg_name ~rel_name in - let (rc, root_opt) = - Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) - in - match (rc, root_opt) with - | (0, Some r) -> Ok r - | (0, None) -> Ok "" - | _ -> Error (Error.handle_error rc "relation_root query failed") + let rc, root_opt = Nt_ffi.with_out_string (fun pp -> Nt_ffi.rnt_relation_root path pp) in + match rc, root_opt with + | 0, Some r -> Ok r + | 0, None -> Ok "" + | _ -> Error (Error.handle_error rc "relation_root query failed") (* -------------------------------------------------------------------------- Prelude / catalog bootstrap @@ -661,12 +614,11 @@ module Make (B : Backend) = struct (multigroup : Management.Multigroup.multigroup) : (branch_handle * Management.Multigroup.multigroup, Condition.t) result = let mg_name = multigroup#name in - let* (branch_handle, multigroup) = + let* branch_handle, multigroup = List.fold_left (fun acc (name, schema) -> - let* (branch_handle, multigroup) = acc in - create_relation branch_handle multigroup - ~branch_name ~name ~schema) + let* branch_handle, multigroup = acc in + create_relation branch_handle multigroup ~branch_name ~name ~schema ) (Ok (branch_handle, multigroup)) Prelude.Catalog.catalog_definitions in @@ -676,18 +628,16 @@ module Make (B : Backend) = struct Prelude.Catalog.catalog_definitions in let* _ = - create_tuples ~branch_name ~mg_name - ~rel_name:Prelude.Catalog.relation_rel_name rel_tuples + create_tuples ~branch_name ~mg_name ~rel_name:Prelude.Catalog.relation_rel_name rel_tuples in let attr_tuples = List.concat_map (fun (rel_name, schema) -> - Prelude.Catalog.build_attribute_tuples ~relation_name:rel_name schema) + Prelude.Catalog.build_attribute_tuples ~relation_name:rel_name schema ) Prelude.Catalog.catalog_definitions in let* _ = - create_tuples ~branch_name ~mg_name - ~rel_name:Prelude.Catalog.attribute_rel_name attr_tuples + create_tuples ~branch_name ~mg_name ~rel_name:Prelude.Catalog.attribute_rel_name attr_tuples in Ok (branch_handle, multigroup) @@ -709,12 +659,8 @@ module Make (B : Backend) = struct let* target = branch_target_of_handle bh in let result = if target = "" then - let mg = - new Management.Multigroup.multigroup - ~name:Prelude.Catalog.prelude_mg - in - seed_prelude ~branch_name:"master" bh mg - |> Result.map ignore + let mg = new Management.Multigroup.multigroup ~name:Prelude.Catalog.prelude_mg in + seed_prelude ~branch_name:"master" bh mg |> Result.map ignore else Ok () in ignore (Nt_ffi.rnt_close_handle (Nt_ffi.nint_to_ptr bh)); @@ -731,83 +677,155 @@ module Make (B : Backend) = struct | Some rel -> let gen : Generator.t = match rel#kind with - | `Ephemeral | `Domain -> - ((Obj.magic rel) : < generator : Generator.t >)#generator + | `Ephemeral | `Domain -> (Obj.magic rel : < generator: Generator.t >)#generator | `Pseudo -> - ((Obj.magic rel) - : < as_generator : - (string * Conventions.AbstractValue.t) list -> Generator.t >) - #as_generator [] + ( Obj.magic rel + : < as_generator: (string * Conventions.AbstractValue.t) list -> Generator.t > ) + #as_generator + [] | `Stored -> fun _pos -> Generator.Error - ("stored relation must be accessed via Nt.execute_query: " - ^ rel#name) + ("stored relation must be accessed via Nt.execute_query: " ^ rel#name) in Some - (new Relation.ephemeral ~name:rel#name ~schema:rel#schema - ~constraints:rel#constraints ~cardinality:rel#cardinality - ~membership_criteria:rel#membership_criteria - ~lineage:(Some rel#lineage) ~provenance:(Some rel#provenance) - ~generator:gen) - + (new Relation.ephemeral + ~name:rel#name ~schema:rel#schema ~constraints:rel#constraints + ~cardinality:rel#cardinality ~membership_criteria:rel#membership_criteria + ~lineage:(Some rel#lineage) ~provenance:(Some rel#provenance) ~generator:gen ) end module type S = sig - val initialize : unit -> (unit, Condition.t) result + val initialize : unit -> (unit, Condition.t) result val authenticate : auth_method -> (claims, Condition.t) result - - val session_open : unit -> (string, Condition.t) result - val session_close : string -> (unit, Condition.t) result + val session_open : unit -> (string, Condition.t) result + val session_close : string -> (unit, Condition.t) result val session_set_branch : string -> string -> string -> (unit, Condition.t) result - val open_branch : claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val open_snapshot : claims -> string -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val close_branch : branch_handle -> (unit, Condition.t) result + val open_branch : + claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val open_snapshot : + claims -> + string -> + string -> + (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val close_branch : branch_handle -> (unit, Condition.t) result val branch_target_of_handle : branch_handle -> (string, Condition.t) result - val list_relations : branch_name:string -> mg_name:string -> ((string * string) list, Condition.t) result + val list_relations : + branch_name:string -> mg_name:string -> ((string * string) list, Condition.t) result + val list_branch_multigroups : string -> ((string * string) list, Condition.t) result val list_snapshot_relations : string -> ((string * string) list, Condition.t) result - val open_relation : branch_name:string -> mg_name:string -> rel_name:string -> (relation_handle, Condition.t) result + val open_relation : + branch_name:string -> mg_name:string -> rel_name:string -> (relation_handle, Condition.t) result + val close_relation : relation_handle -> (unit, Condition.t) result val register_ephemeral : - session:string -> named:bool -> name:string -> + session:string -> + named:bool -> + name:string -> generator:(offset:int -> limit:int -> Tuple.materialized list) -> - cardinality:Conventions.Cardinality.t -> identity:string -> - schema:Schema.t -> deps:string list -> (string, Condition.t) result - val drop_ephemeral : session:string -> name:string -> (unit, Condition.t) result + cardinality:Conventions.Cardinality.t -> + identity:string -> + schema:Schema.t -> + deps:string list -> + (string, Condition.t) result + val drop_ephemeral : session:string -> name:string -> (unit, Condition.t) result val execute_query : plan_node -> rel_name:string -> (tuple_stream, Condition.t) result - val stream_next : tuple_stream -> (Tuple.materialized option, Condition.t) result - val stream_close : tuple_stream -> (unit, Condition.t) result - + val stream_next : tuple_stream -> (Tuple.materialized option, Condition.t) result + val stream_close : tuple_stream -> (unit, Condition.t) result val get_relation : Management.Multigroup.multigroup -> string -> Relation.ephemeral option - val create_multigroup : claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val create_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> name:string -> schema:Schema.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val retract_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val clear_relation : branch_handle -> Management.Multigroup.multigroup -> branch_name:string -> mg_name:string -> Relation.relation -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val register_domain : branch_handle -> Management.Multigroup.multigroup -> Relation.domain -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - val create_immutable_relation : branch_handle -> Management.Multigroup.multigroup -> name:string -> schema:Schema.t -> generator:Generator.t -> membership_criteria:(Tuple.t -> bool) -> cardinality:Conventions.Cardinality.t -> producer:Relation.producer option -> (branch_handle * Management.Multigroup.multigroup * Relation.relation, Condition.t) result - val register_constraint : branch_handle -> Management.Multigroup.multigroup -> constraint_name:string -> relation_name:string -> body:Constraint.t -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result - - val create_tuple : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized -> (string, Condition.t) result - val create_tuples : branch_name:string -> mg_name:string -> rel_name:string -> Tuple.materialized list -> (string, Condition.t) result - val retract_tuple : branch_name:string -> mg_name:string -> rel_name:string -> string -> (unit, Condition.t) result - - val insert_tuple : branch_name:string -> mg_name:string -> rel_name:string -> (string * string) list -> (string, Condition.t) result - val relation_root : branch_name:string -> mg_name:string -> rel_name:string -> (string, Condition.t) result + val create_multigroup : + claims -> string -> (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val create_relation : + branch_handle -> + Management.Multigroup.multigroup -> + branch_name:string -> + name:string -> + schema:Schema.t -> + (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val retract_relation : + branch_handle -> + Management.Multigroup.multigroup -> + name:string -> + (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val clear_relation : + branch_handle -> + Management.Multigroup.multigroup -> + branch_name:string -> + mg_name:string -> + Relation.relation -> + (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val register_domain : + branch_handle -> + Management.Multigroup.multigroup -> + Relation.domain -> + (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val create_immutable_relation : + branch_handle -> + Management.Multigroup.multigroup -> + name:string -> + schema:Schema.t -> + generator:Generator.t -> + membership_criteria:(Tuple.t -> bool) -> + cardinality:Conventions.Cardinality.t -> + producer:Relation.producer option -> + (branch_handle * Management.Multigroup.multigroup * Relation.relation, Condition.t) result + + val register_constraint : + branch_handle -> + Management.Multigroup.multigroup -> + constraint_name:string -> + relation_name:string -> + body:Constraint.t -> + (branch_handle * Management.Multigroup.multigroup, Condition.t) result + + val create_tuple : + branch_name:string -> + mg_name:string -> + rel_name:string -> + Tuple.materialized -> + (string, Condition.t) result + + val create_tuples : + branch_name:string -> + mg_name:string -> + rel_name:string -> + Tuple.materialized list -> + (string, Condition.t) result + + val retract_tuple : + branch_name:string -> mg_name:string -> rel_name:string -> string -> (unit, Condition.t) result + + val insert_tuple : + branch_name:string -> + mg_name:string -> + rel_name:string -> + (string * string) list -> + (string, Condition.t) result + + val relation_root : + branch_name:string -> mg_name:string -> rel_name:string -> (string, Condition.t) result end module Sqlite = Make (struct - let driver = "sqlite" + let driver = "sqlite" let init_arg = ":memory:" end) module Memory = Make (struct - let driver = "memory" + let driver = "memory" let init_arg = "" end) diff --git a/lib/nt_ffi.ml b/lib/nt_ffi.ml index 6759a17..962e1a7 100644 --- a/lib/nt_ffi.ml +++ b/lib/nt_ffi.ml @@ -7,23 +7,17 @@ open Foreign let fn name typ = foreign name typ (* Runtime ----------------------------------------------------------------- *) -let rnt_init = - fn "rnt_init" (string @-> string @-> returning int) +let rnt_init = fn "rnt_init" (string @-> string @-> returning int) (* Auth -------------------------------------------------------------------- *) -let rnt_firewall = - fn "rnt_firewall" (string @-> ptr (ptr char) @-> returning int) +let rnt_firewall = fn "rnt_firewall" (string @-> ptr (ptr char) @-> returning int) (* Session lifecycle ------------------------------------------------------- *) -let rnt_session_open = - fn "rnt_session_open" (ptr void @-> ptr (ptr char) @-> returning int) - -let rnt_session_close = - fn "rnt_session_close" (string @-> returning int) +let rnt_session_open = fn "rnt_session_open" (ptr void @-> ptr (ptr char) @-> returning int) +let rnt_session_close = fn "rnt_session_close" (string @-> returning int) let rnt_session_set_branch = - fn "rnt_session_set_branch" - (string @-> string @-> string @-> returning int) + fn "rnt_session_set_branch" (string @-> string @-> string @-> returning int) (* Ephemeral relations ------------------------------------------------------ *) @@ -32,45 +26,41 @@ let rnt_session_set_branch = for as long as RNT may invoke it (Nt retains them, see Nt.retained_generators). *) let rnt_generator_fn = - funptr - (ptr void @-> string @-> size_t @-> size_t @-> ptr void @-> returning int) + funptr (ptr void @-> string @-> size_t @-> size_t @-> ptr void @-> returning int) -let rnt_sink_emit = - fn "rnt_sink_emit" (ptr void @-> string @-> returning int) +let rnt_sink_emit = fn "rnt_sink_emit" (ptr void @-> string @-> returning int) let rnt_register_ephemeral_relation = fn "rnt_register_ephemeral_relation" - (string @-> int @-> string @-> rnt_generator_fn @-> ptr void @-> int - @-> string @-> string @-> string @-> ptr (ptr char) @-> returning int) + ( string + @-> int + @-> string + @-> rnt_generator_fn + @-> ptr void + @-> int + @-> string + @-> string + @-> string + @-> ptr (ptr char) + @-> returning int ) let rnt_drop_ephemeral_relation = fn "rnt_drop_ephemeral_relation" (string @-> string @-> returning int) (* Handle lifecycle -------------------------------------------------------- *) -let rnt_open_handle = - fn "rnt_open_handle" (string @-> ptr void @-> returning (ptr void)) - -let rnt_close_handle = - fn "rnt_close_handle" (ptr void @-> returning int) +let rnt_open_handle = fn "rnt_open_handle" (string @-> ptr void @-> returning (ptr void)) +let rnt_close_handle = fn "rnt_close_handle" (ptr void @-> returning int) (* Branch hash-pointer ----------------------------------------------------- *) -let rnt_branch_target = - fn "rnt_branch_target" - (ptr void @-> ptr (ptr char) @-> returning int) - -let rnt_branch_advance = - fn "rnt_branch_advance" (string @-> string @-> returning int) +let rnt_branch_target = fn "rnt_branch_target" (ptr void @-> ptr (ptr char) @-> returning int) +let rnt_branch_advance = fn "rnt_branch_advance" (string @-> string @-> returning int) (* Object registration ----------------------------------------------------- *) -let rnt_register_relation = - fn "rnt_register_relation" (string @-> returning int) - -let rnt_register_branch = - fn "rnt_register_branch" (string @-> string @-> returning int) +let rnt_register_relation = fn "rnt_register_relation" (string @-> returning int) +let rnt_register_branch = fn "rnt_register_branch" (string @-> string @-> returning int) (* Branch / snapshot relation enumeration ----------------------------------- *) -let rnt_list_relations = - fn "rnt_list_relations" (string @-> ptr (ptr char) @-> returning int) +let rnt_list_relations = fn "rnt_list_relations" (string @-> ptr (ptr char) @-> returning int) let rnt_list_branch_multigroups = fn "rnt_list_branch_multigroups" (string @-> ptr (ptr char) @-> returning int) @@ -79,29 +69,15 @@ let rnt_list_snapshot_relations = fn "rnt_list_snapshot_relations" (string @-> ptr (ptr char) @-> returning int) (* Tuple storage ----------------------------------------------------------- *) -let rnt_link_tuple = - fn "rnt_link_tuple" - (string @-> string @-> ptr (ptr char) @-> returning int) - -let rnt_unlink_tuple = - fn "rnt_unlink_tuple" (string @-> string @-> returning int) - -let rnt_clear_relation = - fn "rnt_clear_relation" (string @-> returning int) - -let rnt_relation_root = - fn "rnt_relation_root" - (string @-> ptr (ptr char) @-> returning int) +let rnt_link_tuple = fn "rnt_link_tuple" (string @-> string @-> ptr (ptr char) @-> returning int) +let rnt_unlink_tuple = fn "rnt_unlink_tuple" (string @-> string @-> returning int) +let rnt_clear_relation = fn "rnt_clear_relation" (string @-> returning int) +let rnt_relation_root = fn "rnt_relation_root" (string @-> ptr (ptr char) @-> returning int) (* Cursor and VM ----------------------------------------------------------- *) -let rnt_cursor_open = - fn "rnt_cursor_open" (ptr void @-> returning (ptr void)) - -let rnt_cursor_next = - fn "rnt_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int) - -let rnt_cursor_close = - fn "rnt_cursor_close" (ptr void @-> returning int) +let rnt_cursor_open = fn "rnt_cursor_open" (ptr void @-> returning (ptr void)) +let rnt_cursor_next = fn "rnt_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int) +let rnt_cursor_close = fn "rnt_cursor_close" (ptr void @-> returning int) (* VM plan builder --------------------------------------------------------- *) @@ -112,65 +88,56 @@ let rnt_cursor_close = the rnt_plan_assemble call (the C side copies immediately). *) type plan_args_scan + let plan_args_scan : plan_args_scan structure typ = structure "PlanArgsScan" let scan_relation_path = field plan_args_scan "relation_path" (ptr char) let () = seal plan_args_scan type plan_args_join + let plan_args_join : plan_args_join structure typ = structure "PlanArgsJoin" -let join_left = field plan_args_join "left" (ptr void) +let join_left = field plan_args_join "left" (ptr void) let join_right = field plan_args_join "right" (ptr void) let () = seal plan_args_join type plan_args_take + let plan_args_take : plan_args_take structure typ = structure "PlanArgsTake" let take_source = field plan_args_take "source" (ptr void) -let take_limit = field plan_args_take "limit" size_t +let take_limit = field plan_args_take "limit" size_t let () = seal plan_args_take type plan_args_project -let plan_args_project : plan_args_project structure typ = - structure "PlanArgsProject" + +let plan_args_project : plan_args_project structure typ = structure "PlanArgsProject" let project_source = field plan_args_project "source" (ptr void) -let project_attrs = field plan_args_project "attrs" (ptr (ptr char)) +let project_attrs = field plan_args_project "attrs" (ptr (ptr char)) let () = seal plan_args_project type plan_action + let plan_action : plan_action structure typ = structure "PlanAction" let action_operation = field plan_action "operation" int -let action_scan = field plan_action "scan" plan_args_scan -let action_join = field plan_action "join" plan_args_join -let action_take = field plan_action "take" plan_args_take -let action_project = field plan_action "project" plan_args_project +let action_scan = field plan_action "scan" plan_args_scan +let action_join = field plan_action "join" plan_args_join +let action_take = field plan_action "take" plan_args_take +let action_project = field plan_action "project" plan_args_project let () = seal plan_action (* nt::Operation values, RNT include/VM.h *) -let fol_operation_scan = 1 -let fol_operation_join = 2 -let fol_operation_take = 3 +let fol_operation_scan = 1 +let fol_operation_join = 2 +let fol_operation_take = 3 let fol_operation_project = 4 - -let rnt_plan_assemble = - fn "rnt_plan_assemble" (plan_action @-> returning (ptr void)) - -let rnt_plan_free = - fn "rnt_plan_free" (ptr void @-> returning void) - -let rnt_vm_execute_plan = - fn "rnt_vm_execute_plan" (ptr void @-> returning (ptr void)) - -let rnt_vm_cursor_next = - fn "rnt_vm_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int) - -let rnt_vm_cursor_close = - fn "rnt_vm_cursor_close" (ptr void @-> returning int) +let rnt_plan_assemble = fn "rnt_plan_assemble" (plan_action @-> returning (ptr void)) +let rnt_plan_free = fn "rnt_plan_free" (ptr void @-> returning void) +let rnt_vm_execute_plan = fn "rnt_vm_execute_plan" (ptr void @-> returning (ptr void)) +let rnt_vm_cursor_next = fn "rnt_vm_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int) +let rnt_vm_cursor_close = fn "rnt_vm_cursor_close" (ptr void @-> returning int) (* Memory management ------------------------------------------------------- *) -let rnt_free_string = - fn "rnt_free_string" (ptr char @-> returning void) - -let rnt_free_bytes = - fn "rnt_free_bytes" (ptr uint8_t @-> returning void) +let rnt_free_string = fn "rnt_free_string" (ptr char @-> returning void) +let rnt_free_bytes = fn "rnt_free_bytes" (ptr uint8_t @-> returning void) (* -------------------------------------------------------------------------- Helpers shared by Nt (not exported from the library module) @@ -188,25 +155,23 @@ let cstring (s : string) : char CArray.t = (* Reads a null-terminated C string from a char pointer, then frees it. *) let consume_cstring (p : char ptr) : string = let n = ref 0 in - while !@(p +@ !n) <> '\000' do incr n done; + while !@(p +@ !n) <> '\000' do + incr n + done; let s = string_from_ptr p ~length:!n in - rnt_free_string p; - s + rnt_free_string p; s (* Allocates a char* out-parameter, calls [f], returns the rc and string. *) let with_out_string (f : char ptr ptr -> int) : int * string option = let pp = allocate (ptr char) null_char_ptr in let rc = f pp in - let p = !@ pp in - if is_null p then (rc, None) - else (rc, Some (consume_cstring p)) + let p = !@pp in + if is_null p then rc, None else rc, Some (consume_cstring p) (* Converts a void* (returned from open_handle / cursor_open) to nativeint. Returns None when the pointer is NULL (failure). *) let ptr_to_opt (p : unit ptr) : nativeint option = - if is_null p then None - else Some (raw_address_of_ptr p) + if is_null p then None else Some (raw_address_of_ptr p) (* Converts a stored nativeint back to a void* for API calls. *) -let nint_to_ptr (n : nativeint) : unit ptr = - ptr_of_raw_address n +let nint_to_ptr (n : nativeint) : unit ptr = ptr_of_raw_address n diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml index 01721b2..26fe30c 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -7,7 +7,7 @@ written to by any executor. They appear to be stubs for trigger/timing metadata that was never implemented. *) -(** Dedicated multigroup hosting the system catalog. The catalog's relation +(** Dedicated multigroup hosting the system catalog. The catalog's relation names keep the [public:] prefix — that prefix is part of the relation name inside this mg, not a separate namespace. *) let prelude_mg = "sakura" @@ -28,8 +28,7 @@ let loaded_library_rel_name = catalog_prefix ^ "loaded_library" (** Relations present in every multigroup's catalog. *) let catalog_relation_names = - [ - relation_rel_name; + [ relation_rel_name; domain_rel_name; attribute_rel_name; constraint_rel_name; @@ -37,15 +36,12 @@ let catalog_relation_names = timing_rel_name; schema_rel_name; function_predicate_rel_name; - loaded_library_rel_name; - ] + loaded_library_rel_name ] (** Relations exclusive to the sakura meta-multigroup. *) -let sakura_only_relation_names = [ multigroup_rel_name ] - -let all_catalog_relation_names = - catalog_relation_names @ sakura_only_relation_names +let sakura_only_relation_names = [multigroup_rel_name] +let all_catalog_relation_names = catalog_relation_names @ sakura_only_relation_names let is_catalog_relation name = List.mem name all_catalog_relation_names let relation_schema : Schema.t = Schema.empty |> Schema.add "name" "string" let domain_schema : Schema.t = Schema.empty |> Schema.add "name" "string" @@ -57,8 +53,7 @@ let attribute_schema : Schema.t = |> Schema.add "domain_name" "string" let constraint_schema : Schema.t = - Schema.empty |> Schema.add "name" "string" - |> Schema.add "relation_name" "string" + Schema.empty |> Schema.add "name" "string" |> Schema.add "relation_name" "string" let on_schema : Schema.t = Schema.empty |> Schema.add "event" "string" let timing_schema : Schema.t = Schema.empty |> Schema.add "timing" "string" @@ -66,108 +61,74 @@ 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" -let loaded_library_schema : Schema.t = - Schema.empty |> Schema.add "path" "string" +let loaded_library_schema : Schema.t = Schema.empty |> Schema.add "path" "string" (** Definitions seeded into every multigroup. *) let catalog_definitions = - [ - (relation_rel_name, relation_schema); - (domain_rel_name, domain_schema); - (attribute_rel_name, attribute_schema); - (constraint_rel_name, constraint_schema); - (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); - ] + [ relation_rel_name, relation_schema; + domain_rel_name, domain_schema; + attribute_rel_name, attribute_schema; + constraint_rel_name, constraint_schema; + 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. *) -let sakura_only_definitions = [ (multigroup_rel_name, multigroup_schema) ] +let sakura_only_definitions = [multigroup_rel_name, multigroup_schema] (* TODO: all tuple builders use Obj.magic to coerce string values into Attribute.value (Obj.t). This is the same UB pattern fixed in standard.ml; should use Obj.repr instead. *) let build_relation_tuple rel_name : Tuple.materialized = - { - Tuple.relation = relation_rel_name; - attributes = - Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic rel_name }; - } + { Tuple.relation= relation_rel_name; + attributes= Tuple.AttributeMap.singleton "name" {Attribute.value= Obj.magic rel_name} } let build_domain_tuple dom_name : Tuple.materialized = - { - Tuple.relation = domain_rel_name; - attributes = - Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic dom_name }; - } - -let build_attribute_tuples ~relation_name (schema : Schema.t) : - Tuple.materialized list = + { Tuple.relation= domain_rel_name; + attributes= Tuple.AttributeMap.singleton "name" {Attribute.value= Obj.magic dom_name} } + +let build_attribute_tuples ~relation_name (schema : Schema.t) : Tuple.materialized list = List.map (fun (attr_n, dom_n) -> - { - Tuple.relation = attribute_rel_name; - attributes = + { Tuple.relation= attribute_rel_name; + attributes= Tuple.AttributeMap.of_list - [ - ("relation_name", { Attribute.value = Obj.magic relation_name }); - ("attr_name", { Attribute.value = Obj.magic attr_n }); - ("domain_name", { Attribute.value = Obj.magic dom_n }); - ]; - }) + [ "relation_name", {Attribute.value= Obj.magic relation_name}; + "attr_name", {Attribute.value= Obj.magic attr_n}; + "domain_name", {Attribute.value= Obj.magic dom_n} ] } ) schema let build_constraint_tuple cname rel_name : Tuple.materialized = - { - Tuple.relation = constraint_rel_name; - attributes = + { Tuple.relation= constraint_rel_name; + attributes= Tuple.AttributeMap.of_list - [ - ("name", { Attribute.value = Obj.magic cname }); - ("relation_name", { Attribute.value = Obj.magic rel_name }); - ]; - } + [ "name", {Attribute.value= Obj.magic cname}; + "relation_name", {Attribute.value= Obj.magic rel_name} ] } let build_on_tuple event : Tuple.materialized = - { - Tuple.relation = on_rel_name; - attributes = - Tuple.AttributeMap.singleton "event" { Attribute.value = Obj.magic event }; - } + { Tuple.relation= on_rel_name; + attributes= Tuple.AttributeMap.singleton "event" {Attribute.value= Obj.magic event} } let build_timing_tuple timing : Tuple.materialized = - { - Tuple.relation = timing_rel_name; - attributes = - Tuple.AttributeMap.singleton "timing" - { Attribute.value = Obj.magic timing }; - } + { Tuple.relation= timing_rel_name; + attributes= Tuple.AttributeMap.singleton "timing" {Attribute.value= Obj.magic timing} } let build_multigroup_tuple mg_name : Tuple.materialized = - { - Tuple.relation = multigroup_rel_name; - attributes = - Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic mg_name }; - } + { Tuple.relation= multigroup_rel_name; + attributes= Tuple.AttributeMap.singleton "name" {Attribute.value= Obj.magic mg_name} } let build_schema_tuple schema_name : Tuple.materialized = - { - Tuple.relation = schema_rel_name; - attributes = - Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic schema_name }; - } + { Tuple.relation= schema_rel_name; + attributes= Tuple.AttributeMap.singleton "name" {Attribute.value= Obj.magic schema_name} } let purity_to_string p = Sexplib.Sexp.to_string (Conventions.Purity.sexp_of_t p) @@ -176,33 +137,22 @@ let purity_of_string s = | p -> Some p | exception _ -> None -let cardinality_to_string c = - Sexplib.Sexp.to_string (Conventions.Cardinality.sexp_of_t c) +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 = +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) }); - ]; - } + [ "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 }; - } + { Tuple.relation= loaded_library_rel_name; + attributes= Tuple.AttributeMap.singleton "path" {Attribute.value= Obj.magic path} } diff --git a/lib/prelude/domains.ml b/lib/prelude/domains.ml index 9dc9c86..264bf03 100644 --- a/lib/prelude/domains.ml +++ b/lib/prelude/domains.ml @@ -1,22 +1,20 @@ -(** Predefined fundamental domains. Each domain carries a generator - (for enumeration) and membership criteria (for validation). Values - are stored as {!Conventions.AbstractValue.t} via [Obj.magic], - following the same convention as {!Standard}. *) +(** Predefined fundamental domains. Each domain carries a generator (for + enumeration) and membership criteria (for validation). Values are stored as + {!Conventions.AbstractValue.t} via [Obj.magic], following the same + convention as {!Standard}. *) -(** Bijection from natural number to integer: 0->0, 1->1, 2->-1, 3->2, 4->-2, ... *) -let nat_to_int n = - if n = 0 then 0 else if n mod 2 = 1 then (n + 1) / 2 else -(n / 2) +(** Bijection from natural number to integer: 0->0, 1->1, 2->-1, 3->2, 4->-2, + ... *) +let nat_to_int n = if n = 0 then 0 else if n mod 2 = 1 then (n + 1) / 2 else -(n / 2) (** Cantor pairing inverse: given position [n], returns a pair [(a, b)] of natural numbers such that [a + b] lies on the [n]-th diagonal. *) let cantor_unpair n = - let w = - int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) - in + let w = int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) in let t = w * (w + 1) / 2 in let b = n - t in let a = w - b in - (a, b) + a, b (** Integer domain: all integers, enumerated via a bijection from the naturals. Schema: [value: integer]. *) @@ -25,32 +23,18 @@ let integer : Relation.domain = match position with | Some n -> let v = nat_to_int n in - let attributes = - Tuple.AttributeMap.of_list [ ("value", Obj.magic v) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"integer" ~attributes, generator) - | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the integer domain." + let attributes = Tuple.AttributeMap.of_list ["value", Obj.magic v] in + Generator.Value (Tuple.make_materialized ~relation:"integer" ~attributes, generator) + | None -> Generator.Error "Cannot produce a randomly enumerated value for the integer domain." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized _ -> true | Tuple.NonMaterialized _ -> false in - let schema = - Schema.empty - |> Schema.add "value" "integer" - in + let schema = Schema.empty |> Schema.add "value" "integer" in new Relation.domain - ~name:"integer" - ~generator - ~membership_criteria - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:None - ~provenance:None + ~name:"integer" ~generator ~membership_criteria ~schema ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero ~lineage:None ~provenance:None (** Natural number domain: non-negative integers (0, 1, 2, …). Schema: [value: natural]. *) @@ -58,35 +42,21 @@ let natural : Relation.domain = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let attributes = - Tuple.AttributeMap.of_list [ ("value", Obj.magic n) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"natural" ~attributes, generator) - | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the natural domain." + let attributes = Tuple.AttributeMap.of_list ["value", Obj.magic n] in + Generator.Value (Tuple.make_materialized ~relation:"natural" ~attributes, generator) + | None -> Generator.Error "Cannot produce a randomly enumerated value for the natural domain." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match Tuple.AttributeMap.find_opt "value" m.attributes with - | Some attr -> (Obj.magic attr : int) >= 0 - | None -> false) + match Tuple.AttributeMap.find_opt "value" m.attributes with + | Some attr -> (Obj.magic attr : int) >= 0 + | None -> false ) | Tuple.NonMaterialized _ -> false in - let schema = - Schema.empty - |> Schema.add "value" "natural" - in + let schema = Schema.empty |> Schema.add "value" "natural" in new Relation.domain - ~name:"natural" - ~generator - ~membership_criteria - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:None - ~provenance:None + ~name:"natural" ~generator ~membership_criteria ~schema ~constraints:None + ~cardinality:Conventions.Cardinality.AlephZero ~lineage:None ~provenance:None (** Rational number domain: pairs [(numerator, denominator)] where the denominator is never zero. The generator enumerates all such pairs via @@ -101,50 +71,35 @@ let rational : Relation.domain = (* Map b -> non-zero integer: 0->1, 1->-1, 2->2, 3->-2, … *) let den = if b mod 2 = 0 then (b / 2) + 1 else -((b + 1) / 2) in let attributes = - Tuple.AttributeMap.of_list - [ ("numerator", Obj.magic num); ("denominator", Obj.magic den) ] + Tuple.AttributeMap.of_list ["numerator", Obj.magic num; "denominator", Obj.magic den] in - Generator.Value - (Tuple.make_materialized ~relation:"rational" ~attributes, generator) - | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the rational domain." + Generator.Value (Tuple.make_materialized ~relation:"rational" ~attributes, generator) + | None -> Generator.Error "Cannot produce a randomly enumerated value for the rational domain." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match Tuple.AttributeMap.find_opt "denominator" m.attributes with - | Some attr -> (Obj.magic attr : int) <> 0 - | None -> false) + match Tuple.AttributeMap.find_opt "denominator" m.attributes with + | Some attr -> (Obj.magic attr : int) <> 0 + | None -> false ) | Tuple.NonMaterialized _ -> false in (* Note: Additionally to the membership criteria, we add the constraint here as this relation can be further dismembered, rendering the denominator into a lone integer, that should propagate the constraint `integer <> 0`. If we declared a domain `integer_without_zero`, then this constraint would not be needed as the domain would not be dissociated from the value. *) - let constraints: Relation.RelationConstraint.t option = + let constraints : Relation.RelationConstraint.t option = let denominator_not_zero = let open Constraint in - Not - { body = Eq {left = Var "denominator"; right = Const (Obj.magic 0)} - ; universe = "integer" } + Not {body= Eq {left= Var "denominator"; right= Const (Obj.magic 0)}; universe= "integer"} in - Some (("DENOMINATOR_DIFFERENT_FROM_ZERO", denominator_not_zero) - |> List.singleton) + Some (("DENOMINATOR_DIFFERENT_FROM_ZERO", denominator_not_zero) |> List.singleton) in let schema = - Schema.empty - |> Schema.add "numerator" "integer" - |> Schema.add "denominator" "integer" + Schema.empty |> Schema.add "numerator" "integer" |> Schema.add "denominator" "integer" in new Relation.domain - ~name:"rational" - ~generator - ~membership_criteria - ~schema - ~constraints - ~cardinality:Conventions.Cardinality.AlephZero - ~lineage:None - ~provenance:None + ~name:"rational" ~generator ~membership_criteria ~schema ~constraints + ~cardinality:Conventions.Cardinality.AlephZero ~lineage:None ~provenance:None (** String domain: any string value. Not enumerable. Schema: [value: string]. *) let string : Relation.domain = @@ -155,17 +110,9 @@ let string : Relation.domain = | Tuple.Materialized _ -> true | Tuple.NonMaterialized _ -> false in - let schema = - Schema.empty - |> Schema.add "value" "string" - in + let schema = Schema.empty |> Schema.add "value" "string" in new Relation.domain - ~name:"string" - ~generator - ~membership_criteria - ~schema + ~name:"string" ~generator ~membership_criteria ~schema ~constraints:None - (* TODO: Implement some form of enumeration for strings with a bijection on naturals. *) - ~cardinality:Conventions.Cardinality.Continuum - ~lineage:None - ~provenance:None + (* TODO: Implement some form of enumeration for strings with a bijection on naturals. *) + ~cardinality:Conventions.Cardinality.Continuum ~lineage:None ~provenance:None diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml index f38ee40..3822700 100644 --- a/lib/prelude/standard.ml +++ b/lib/prelude/standard.ml @@ -5,37 +5,26 @@ Stdlib.compare on Obj.t, which only works correctly for unboxed integers. Extending to other domains requires a proper typed comparison dispatch. *) -let mk v = { Attribute.value = Obj.repr v } +let mk v = {Attribute.value= Obj.repr v} (** Build a comparison relation over a single domain. [pred] receives the result of [Stdlib.compare left right]. *) let make_comparison ~name ~domain_name ~pred ~cardinality ~generator = - let schema = - Schema.empty - |> Schema.add "left" domain_name - |> Schema.add "right" domain_name - in + let schema = Schema.empty |> Schema.add "left" domain_name |> Schema.add "right" domain_name in let membership_criteria : (*(string -> Merkle.t option) ->*) Tuple.t -> bool = - (* fun _tree_of -> function *) - 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 + (* fun _tree_of -> function *) + 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 in new Relation.ephemeral - ~name - ~schema - ~constraints:None - ~cardinality - ~generator - ~membership_criteria - ~provenance:None + ~name ~schema ~constraints:None ~cardinality ~generator ~membership_criteria ~provenance:None ~lineage:None (** Enumerate pairs (a, b) where a < b using triangular indexing. *) @@ -44,17 +33,15 @@ let pair_of_nat_lt n = let r = int_of_float (floor ((1. +. sqrt (1. +. (8. *. nf))) /. 2.)) in let t_prev = r * (r - 1) / 2 in let left = n - t_prev in - (left, r) + left, r (** Enumerate all pairs (a, b) via Cantor pairing. *) let cantor_pair_of_nat n = - let w = - int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) - in + let w = int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) in let t = w * (w + 1) / 2 in let b = n - t in let a = w - b in - (a, b) + a, b let less_than_natural : Relation.ephemeral = let rec generator (position : int option) : Generator.result = @@ -62,14 +49,10 @@ let less_than_natural : Relation.ephemeral = | Some position -> let left, right = pair_of_nat_lt position in let attributes : Attribute.materialized Tuple.AttributeMap.t = - Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] + Tuple.AttributeMap.of_list ["left", mk left; "right", mk right] in - Generator.Value - (Tuple.make_materialized ~relation:"less_than" ~attributes, generator) - | None -> - Error - "Cannot produce a randomly enumerated value for less_than over \ - naturals." + Generator.Value (Tuple.make_materialized ~relation:"less_than" ~attributes, generator) + | None -> Error "Cannot produce a randomly enumerated value for less_than over naturals." in make_comparison ~name:"natural_natural_less_than" ~domain_name:"natural" ~pred:(fun c -> c < 0) @@ -83,16 +66,12 @@ let less_than_or_equal_natural : Relation.ephemeral = (* a <= b is always true when a <= b; we enumerate all (a, b) with a <= b *) let left = min a b in let right = max a b in - let attributes = - Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] - in + let attributes = Tuple.AttributeMap.of_list ["left", mk left; "right", mk right] in Generator.Value - ( Tuple.make_materialized ~relation:"less_than_or_equal" ~attributes, - generator ) + (Tuple.make_materialized ~relation:"less_than_or_equal" ~attributes, generator) | None -> Error "Cannot enumerate less_than_or_equal randomly." in - make_comparison ~name:"natural_natural_less_than_or_equal" - ~domain_name:"natural" + make_comparison ~name:"natural_natural_less_than_or_equal" ~domain_name:"natural" ~pred:(fun c -> c <= 0) ~cardinality:Conventions.Cardinality.AlephZero ~generator @@ -102,12 +81,8 @@ let greater_than_natural : Relation.ephemeral = | Some n -> let left, right = pair_of_nat_lt n in (* Swap: right > left *) - let attributes = - Tuple.AttributeMap.of_list [ ("left", mk right); ("right", mk left) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"greater_than" ~attributes, - generator ) + let attributes = Tuple.AttributeMap.of_list ["left", mk right; "right", mk left] in + Generator.Value (Tuple.make_materialized ~relation:"greater_than" ~attributes, generator) | None -> Error "Cannot enumerate greater_than randomly." in make_comparison ~name:"natural_natural_greater_than" ~domain_name:"natural" @@ -121,16 +96,12 @@ let greater_than_or_equal_natural : Relation.ephemeral = let a, b = cantor_pair_of_nat n in let left = max a b in let right = min a b in - let attributes = - Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] - in + let attributes = Tuple.AttributeMap.of_list ["left", mk left; "right", mk right] in Generator.Value - ( Tuple.make_materialized ~relation:"greater_than_or_equal" ~attributes, - generator ) + (Tuple.make_materialized ~relation:"greater_than_or_equal" ~attributes, generator) | None -> Error "Cannot enumerate greater_than_or_equal randomly." in - make_comparison ~name:"natural_natural_greater_than_or_equal" - ~domain_name:"natural" + make_comparison ~name:"natural_natural_greater_than_or_equal" ~domain_name:"natural" ~pred:(fun c -> c >= 0) ~cardinality:Conventions.Cardinality.AlephZero ~generator @@ -138,11 +109,8 @@ let equal_natural : Relation.ephemeral = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let attributes = - Tuple.AttributeMap.of_list [ ("left", mk n); ("right", mk n) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"equal" ~attributes, generator) + let attributes = Tuple.AttributeMap.of_list ["left", mk n; "right", mk n] in + Generator.Value (Tuple.make_materialized ~relation:"equal" ~attributes, generator) | None -> Error "Cannot enumerate equal randomly." in make_comparison ~name:"natural_natural_equal" ~domain_name:"natural" @@ -154,12 +122,9 @@ let not_equal_natural : Relation.ephemeral = match position with | Some n -> let a, b = cantor_pair_of_nat n in - let left, right = if a = b then (a, b + 1) else (a, b) in - let attributes = - Tuple.AttributeMap.of_list [ ("left", mk left); ("right", mk right) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"not_equal" ~attributes, generator) + let left, right = if a = b then a, b + 1 else a, b in + let attributes = Tuple.AttributeMap.of_list ["left", mk left; "right", mk right] in + Generator.Value (Tuple.make_materialized ~relation:"not_equal" ~attributes, generator) | None -> Error "Cannot enumerate not_equal randomly." in make_comparison ~name:"natural_natural_not_equal" ~domain_name:"natural" @@ -168,7 +133,9 @@ let not_equal_natural : Relation.ephemeral = let plus_natural : Relation.ephemeral = let schema = - Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" + Schema.empty + |> Schema.add "a" "natural" + |> Schema.add "b" "natural" |> Schema.add "sum" "natural" in let rec generator (position : int option) : Generator.result = @@ -176,42 +143,34 @@ let plus_natural : Relation.ephemeral = | Some n -> let a, b = cantor_pair_of_nat n in let s = a + b in - let attributes = - Tuple.AttributeMap.of_list [ ("a", mk a); ("b", mk b); ("sum", mk s) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"plus" ~attributes, generator) + let attributes = Tuple.AttributeMap.of_list ["a", mk a; "b", mk b; "sum", mk s] in + Generator.Value (Tuple.make_materialized ~relation:"plus" ~attributes, generator) | None -> Error "Cannot enumerate plus randomly." in let membership_criteria : Tuple.t -> bool = - (* fun _tree_of -> *) + (* 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 new Relation.ephemeral - ~name:"natural_plus" - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~generator - ~membership_criteria - ~provenance:None - ~lineage:None + ~name:"natural_plus" ~schema ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero + ~generator ~membership_criteria ~provenance:None ~lineage:None let times_natural : Relation.ephemeral = let schema = - Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" + Schema.empty + |> Schema.add "a" "natural" + |> Schema.add "b" "natural" |> Schema.add "product" "natural" in let rec generator (position : int option) : Generator.result = @@ -219,43 +178,34 @@ let times_natural : Relation.ephemeral = | Some n -> let a, b = cantor_pair_of_nat n in let p = a * b in - let attributes = - Tuple.AttributeMap.of_list - [ ("a", mk a); ("b", mk b); ("product", mk p) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"times" ~attributes, generator) + let attributes = Tuple.AttributeMap.of_list ["a", mk a; "b", mk b; "product", mk p] in + Generator.Value (Tuple.make_materialized ~relation:"times" ~attributes, generator) | None -> Error "Cannot enumerate times randomly." in let membership_criteria : Tuple.t -> bool = - (* fun _tree_of -> *) + (* 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 new Relation.ephemeral - ~name:"natural_times" - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~generator - ~membership_criteria - ~provenance:None - ~lineage:None + ~name:"natural_times" ~schema ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero + ~generator ~membership_criteria ~provenance:None ~lineage:None let minus_natural : Relation.ephemeral = let schema = - Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" + Schema.empty + |> Schema.add "a" "natural" + |> Schema.add "b" "natural" |> Schema.add "difference" "natural" in let rec generator (position : int option) : Generator.result = @@ -264,45 +214,37 @@ let minus_natural : Relation.ephemeral = (* Enumerate pairs where a >= b, so difference >= 0 *) let b, diff = cantor_pair_of_nat n in let a = b + diff in - let attributes = - Tuple.AttributeMap.of_list - [ ("a", mk a); ("b", mk b); ("difference", mk diff) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"minus" ~attributes, generator) + let attributes = Tuple.AttributeMap.of_list ["a", mk a; "b", mk b; "difference", mk diff] in + Generator.Value (Tuple.make_materialized ~relation:"minus" ~attributes, generator) | None -> Error "Cannot enumerate minus randomly." in let membership_criteria : Tuple.t -> bool = - (* fun _tree_of -> *) + (* fun _tree_of -> *) function - | Tuple.Materialized m -> - begin 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 - end - | Tuple.NonMaterialized _ -> false + | Tuple.Materialized m -> + begin 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 + end + | Tuple.NonMaterialized _ -> false in new Relation.ephemeral - ~name:"natural_minus" - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~generator - ~membership_criteria - ~provenance:None - ~lineage:None + ~name:"natural_minus" ~schema ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero + ~generator ~membership_criteria ~provenance:None ~lineage:None let divide_natural : Relation.ephemeral = let schema = - Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" + Schema.empty + |> Schema.add "a" "natural" + |> Schema.add "b" "natural" |> Schema.add "quotient" "natural" |> Schema.add "remainder" "natural" in @@ -318,47 +260,36 @@ let divide_natural : Relation.ephemeral = let r = r_raw mod b in let a = (b * q) + r in let attributes = - Tuple.AttributeMap.of_list - [ - ("a", mk a); ("b", mk b); ("quotient", mk q); ("remainder", mk r); - ] + Tuple.AttributeMap.of_list ["a", mk a; "b", mk b; "quotient", mk q; "remainder", mk r] in - Generator.Value - (Tuple.make_materialized ~relation:"divide" ~attributes, generator) + Generator.Value (Tuple.make_materialized ~relation:"divide" ~attributes, generator) | None -> Error "Cannot enumerate divide randomly." in let membership_criteria : Tuple.t -> bool = - (* fun _tree_of -> *) + (* 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 new Relation.ephemeral - ~name:"natural_divide" - ~schema - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero - ~generator - ~membership_criteria - ~provenance:None - ~lineage:None + ~name:"natural_divide" ~schema ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero + ~generator ~membership_criteria ~provenance:None ~lineage:None let prelude_relations = - [ - less_than_natural; + [ less_than_natural; less_than_or_equal_natural; greater_than_natural; greater_than_or_equal_natural; @@ -367,5 +298,4 @@ let prelude_relations = plus_natural; times_natural; minus_natural; - divide_natural; - ] + divide_natural ] diff --git a/lib/prl/ast.ml b/lib/prl/ast.ml index 1969da6..ab63c31 100644 --- a/lib/prl/ast.ml +++ b/lib/prl/ast.ml @@ -1,12 +1,11 @@ open Sexplib.Std -type function_predicate = { - name : string; - schema : (string * string) list; - symbol : string; - purity : Conventions.Purity.t; - cardinality : Conventions.Cardinality.t; -} +type function_predicate = + { name: string; + schema: (string * string) list; + symbol: string; + purity: Conventions.Purity.t; + cardinality: Conventions.Cardinality.t } [@@deriving sexp] type statement = diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml index fcd4ec0..4a055ae 100644 --- a/lib/prl/executor.ml +++ b/lib/prl/executor.ml @@ -1,11 +1,16 @@ module Make (NT : Nt.S) = struct module Error = struct open Condition + (* TODO: more structure *) let parse_error msg = condition "parse-error" msg empty let runtime_error msg = condition "runtime-error" msg empty - let unknown_plugin_symbol name = condition "unknown-plugin-symbol" "Unknown plugin" ("name" |=| (of_string name)) - let relation_not_found name = condition "relation-not-found" "Relation not found" ("name" |=| (of_string name)) + + let unknown_plugin_symbol name = + condition "unknown-plugin-symbol" "Unknown plugin" ("name" |=| of_string name) + + let relation_not_found name = + condition "relation-not-found" "Relation not found" ("name" |=| of_string name) end let ( let* ) = Result.bind @@ -19,16 +24,15 @@ module Make (NT : Nt.S) = struct let execute (_ctx : Sublanguage_context.t) (_stmt : Ast.statement) : (Sublanguage_types.result, Condition.t) result = - Error (Error.runtime_error - "PRL execution is temporarily disabled pending VM callback-cursor support") + Error + (Error.runtime_error + "PRL execution is temporarily disabled pending VM callback-cursor support" ) - let _execute_load_library _ctx _path = - Error (Error.runtime_error "PRL disabled") + let _execute_load_library _ctx _path = Error (Error.runtime_error "PRL disabled") let _execute_define_function_predicate _ctx (_spec : Ast.function_predicate) = let* _ = Ok () in Error (Error.runtime_error "PRL disabled") - let _execute_list_function_predicates _ctx = - Error (Error.runtime_error "PRL disabled") + let _execute_list_function_predicates _ctx = Error (Error.runtime_error "PRL disabled") end diff --git a/lib/prl/parser.ml b/lib/prl/parser.ml index 2567eea..e009b97 100644 --- a/lib/prl/parser.ml +++ b/lib/prl/parser.ml @@ -1,12 +1,11 @@ module Error = struct open Condition + let parse_error msg = condition "parse-error" msg empty end let of_sexp sexp = - let sexp = - match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other - in + 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 (Error.parse_error (Printexc.to_string exn)) diff --git a/lib/prl/runtime.ml b/lib/prl/runtime.ml index 9ebef84..103b5c1 100644 --- a/lib/prl/runtime.ml +++ b/lib/prl/runtime.ml @@ -1,7 +1,6 @@ -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 () } +let state : t = {loaded_libraries= Hashtbl.create 16; mutex= Mutex.create ()} let load_library path : (unit, string) result = Mutex.protect state.mutex (fun () -> @@ -11,44 +10,40 @@ let load_library path : (unit, string) result = Dynlink.loadfile path; Hashtbl.replace state.loaded_libraries path (); Ok () - with Dynlink.Error e -> Error (Dynlink.error_message e)) + 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 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) + 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 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 } + | [] -> 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 } acc) rest) + match List.assoc_opt attr_name row with + | None -> None + | Some value -> go (Tuple.AttributeMap.add attr_name {Attribute.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 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." + | None -> Generator.Error "Plugin row does not conform to predicate schema." | Some tuple -> Generator.Value (Tuple.Materialized tuple, gen (i + 1)) in gen 0 @@ -62,21 +57,19 @@ let make_generator relation_name schema (impl : Sakura_prl_api.implementation) 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 = +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) : - Tuple.t -> bool = +let make_membership_criteria schema (impl : Sakura_prl_api.implementation) : 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))) + 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 index 387da34..405d266 100644 --- a/lib/prl/sublanguage.ml +++ b/lib/prl/sublanguage.ml @@ -6,8 +6,6 @@ module Make (NT : Nt.S) = struct let name = "prl" let parse _ = Ok () - let parse_sexp sexp = Parser.of_sexp sexp - let execute = Exec.execute end diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml index a67f815..a73774e 100644 --- a/lib/qualified_name.ml +++ b/lib/qualified_name.ml @@ -4,19 +4,21 @@ further colons are part of the relation name verbatim. Examples: - - ["warehouse:orders"] -> mg=["warehouse"], name=["orders"] + - ["warehouse:orders"] -> mg=["warehouse"], name=["orders"] - ["warehouse:public:orders"] -> mg=["warehouse"], name=["public:orders"] - - ["sakura:public:relation"] -> mg=["sakura"], name=["public:relation"] + - ["sakura:public:relation"] -> mg=["sakura"], name=["public:relation"] A reference with no leading [<mg>:] segment is a parse error — callers must supply the mg explicitly. *) -type t = { mg : string; name : string } +type t = {mg: string; name: string} module Error = struct open Condition - let unqualified_name name = condition "unqualified-name" "A qualified name was expected, but an unqualified one was given" - ("name" |=| (of_string name)) + + let unqualified_name name = + condition "unqualified-name" "A qualified name was expected, but an unqualified one was given" + ("name" |=| of_string name) end exception Unqualified of string @@ -27,12 +29,10 @@ let parse (s : string) : t = | Some i -> let mg = String.sub s 0 i in let name = String.sub s (i + 1) (String.length s - i - 1) in - if mg = "" || name = "" then raise (Unqualified s) - else { mg; name } + if mg = "" || name = "" then raise (Unqualified s) else {mg; name} let try_parse (s : string) : (t, Condition.t) result = try Ok (parse s) with Unqualified s -> Error (Error.unqualified_name s) -let make ~mg ~name = { mg; name } - -let to_string { mg; name } = mg ^ ":" ^ name +let make ~mg ~name = {mg; name} +let to_string {mg; name} = mg ^ ":" ^ name diff --git a/lib/qualified_name.mli b/lib/qualified_name.mli index 0e39ff2..15f80d1 100644 --- a/lib/qualified_name.mli +++ b/lib/qualified_name.mli @@ -3,16 +3,14 @@ The first colon separates the multigroup name from the relation name; any further colons are part of the relation name verbatim. *) -type t = { mg : string; name : string } +type t = {mg: string; name: string} exception Unqualified of string +(** Splits on the first [:]. Raises [Unqualified] when no mg segment is present + (i.e. no colon, or empty mg / empty name). *) val parse : string -> t -(** Splits on the first [:]. Raises [Unqualified] when no mg segment is - present (i.e. no colon, or empty mg / empty name). *) val try_parse : string -> (t, Condition.t) result - val make : mg:string -> name:string -> t - val to_string : t -> string diff --git a/lib/relation.ml b/lib/relation.ml index bba70b3..863316b 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -28,57 +28,51 @@ module Lineage = struct end module Provenance = struct - type source = { relation : Conventions.Name.t; attribute : string } (** Tracks which base relation each attribute originates from. Lives on the relation and refers to the `entity group`. *) + type source = {relation: Conventions.Name.t; attribute: string} type t = | Undefined | Base of Conventions.Name.t | Sources of source list BatMap.String.t - (** Maps attribute name -> list of sources (multiple after joins) *) + (** Maps attribute name -> list of sources (multiple after joins) *) let base ~relation ~attributes : t = Sources (List.fold_left - (fun acc attr -> - BatMap.String.add attr [ { relation; attribute = attr } ] acc) - BatMap.String.empty attributes) + (fun acc attr -> BatMap.String.add attr [{relation; attribute= attr}] acc) + BatMap.String.empty attributes ) let empty : t = Sources BatMap.String.empty - let undefined : t = Undefined end type producer = (string * Conventions.AbstractValue.t) list -> Generator.t +type kind = [`Stored | `Ephemeral | `Pseudo | `Domain] + +class virtual relation = + object (_self) + method virtual kind : kind + method virtual name : Conventions.Name.t + method virtual schema : Schema.t + method virtual hash : Conventions.Hash.t + method virtual constraints : RelationConstraint.t option + method virtual cardinality : Conventions.Cardinality.t + method virtual lineage : Lineage.t + method virtual provenance : Provenance.t + method virtual membership_criteria : Tuple.t -> bool + method virtual timestamp : float + method virtual serialize : unit -> Storable.Relation.t + end -type kind = [ `Stored | `Ephemeral | `Pseudo | `Domain ] - -class virtual relation = object (_self) - method virtual kind : kind - method virtual name : Conventions.Name.t - method virtual schema : Schema.t - method virtual hash : Conventions.Hash.t - method virtual constraints : RelationConstraint.t option - method virtual cardinality : Conventions.Cardinality.t - method virtual lineage : Lineage.t - method virtual provenance : Provenance.t - method virtual membership_criteria : Tuple.t -> bool - method virtual timestamp : float - method virtual serialize : unit -> Storable.Relation.t -end - -class stored - ~name:(init_name : Conventions.Name.t) - ~schema:(init_schema : Schema.t) +class stored ~name:(init_name : Conventions.Name.t) ~schema:(init_schema : Schema.t) ~constraints:(init_constraints : RelationConstraint.t option) ~cardinality:(init_cardinality : Conventions.Cardinality.t) ~membership_criteria:(init_membership : Tuple.t -> bool) - ~lineage:(init_lineage : Lineage.t option) - ~provenance:(init_provenance : Provenance.t option) = + ~lineage:(init_lineage : Lineage.t option) ~provenance:(init_provenance : Provenance.t option) = object inherit relation - val name = init_name val schema = init_schema val tree_pointer : Conventions.Hash.t option = None @@ -87,7 +81,9 @@ class stored val membership_criteria = init_membership val timestamp = Unix.gettimeofday () val lineage = Option.value init_lineage ~default:(Lineage.Base init_name) - val provenance = Option.value init_provenance + + val provenance = + Option.value init_provenance ~default:(Provenance.base ~relation:init_name ~attributes:(Schema.attributes init_schema)) method name = name @@ -101,24 +97,16 @@ class stored method timestamp = timestamp method lineage = lineage method provenance = provenance + method set_tree_pointer tp = {<tree_pointer = tp; timestamp = Unix.gettimeofday ()>} + method set_cardinality c = {<cardinality = c>} + method set_constraints c = {<constraints = c>} - method set_tree_pointer tp = {< tree_pointer = tp; timestamp = Unix.gettimeofday () >} - method set_cardinality c = {< cardinality = c >} - method set_constraints c = {< constraints = c >} method serialize () = - { Storable.Relation.name; - schema; - tree_pointer = Option.value tree_pointer ~default:"" } -end + {Storable.Relation.name; schema; tree_pointer= Option.value tree_pointer ~default:""} + end -class ephemeral - ~name:(init_name : Conventions.Name.t) - ~schema - ~constraints - ~cardinality ~membership_criteria - ~lineage - ~provenance - ~generator:(init_generator : Generator.t) = +class ephemeral ~name:(init_name : Conventions.Name.t) ~schema ~constraints ~cardinality + ~membership_criteria ~lineage ~provenance ~generator:(init_generator : Generator.t) = object inherit relation val name : Conventions.Name.t = init_name @@ -130,7 +118,6 @@ class ephemeral val lineage = Option.value lineage ~default:(Lineage.Base init_name) val provenance = Option.value provenance ~default:(Provenance.Base init_name) val timestamp = Unix.gettimeofday () - method name = name method kind = `Ephemeral method schema = schema @@ -142,13 +129,11 @@ class ephemeral method lineage = lineage method provenance = provenance method timestamp = timestamp - method serialize () = failwith "Ephemeral relations cannot be serialized directly" -end + end -class pseudo - ~name:(init_name : Conventions.Name.t) ~schema ~constraints ~cardinality ~membership_criteria ~lineage ~provenance - ~producer:(init_producer : producer) = +class pseudo ~name:(init_name : Conventions.Name.t) ~schema ~constraints ~cardinality + ~membership_criteria ~lineage ~provenance ~producer:(init_producer : producer) = object inherit relation val name = init_name @@ -160,12 +145,14 @@ class pseudo val lineage = Option.value lineage ~default:(Lineage.Base init_name) val provenance = provenance val timestamp = Unix.gettimeofday () - method name = name method kind = `Pseudo method schema = schema method producer = producer - method as_generator (bindings : (string * Conventions.AbstractValue.t) list) : Generator.t = producer bindings + + method as_generator (bindings : (string * Conventions.AbstractValue.t) list) : Generator.t = + producer bindings + method hash = Conventions.Hash.hash_text (name ^ "pseudo") method constraints = constraints method cardinality = cardinality @@ -176,7 +163,7 @@ class pseudo (* TODO: Remove this from the virtual definition *) method serialize () = failwith "Pseudo relations are procedural" -end + end let deserialize_stored (_bytes : bytes) : (stored, string) result = try @@ -185,18 +172,18 @@ let deserialize_stored (_bytes : bytes) : (stored, string) result = Constraint.build_membership_criteria ~_name:stored.name ~schema:stored.schema in Ok - (new stored ~name:stored.name ~schema:stored.schema ~constraints:None - ~cardinality:Conventions.Cardinality.ConstrainedFinite - ~membership_criteria ~lineage:None ~provenance:None) + (new stored + ~name:stored.name ~schema:stored.schema ~constraints:None + ~cardinality:Conventions.Cardinality.ConstrainedFinite ~membership_criteria ~lineage:None + ~provenance:None ) with Invalid_argument message -> Error message -class domain ~name ~schema ~constraints ~cardinality ~membership_criteria - ~lineage ~provenance ~generator = +class domain ~name ~schema ~constraints ~cardinality ~membership_criteria ~lineage ~provenance + ~generator = object - inherit ephemeral - ~name ~schema ~constraints ~cardinality - ~membership_criteria ~lineage - ~provenance ~generator + inherit + ephemeral + ~name ~schema ~constraints ~cardinality ~membership_criteria ~lineage ~provenance ~generator method! kind = `Domain end diff --git a/lib/schema.ml b/lib/schema.ml index 923284a..cc277a5 100644 --- a/lib/schema.ml +++ b/lib/schema.ml @@ -11,6 +11,4 @@ type t = (string * string) list let empty : t = [] let add name domain_name (schema : t) : t = (name, domain_name) :: schema let attributes (schema : t) = List.map fst schema - -let to_string schema = - List.map (fun (n, t) -> n ^ ":" ^ t) schema |> String.concat "," +let to_string schema = List.map (fun (n, t) -> n ^ ":" ^ t) schema |> String.concat "," diff --git a/lib/scl/ast.ml b/lib/scl/ast.ml index 043f544..41a5239 100644 --- a/lib/scl/ast.ml +++ b/lib/scl/ast.ml @@ -1,7 +1,7 @@ open Sexplib.Std type statement = - | Begin of { query : Drl.Ast.query; limit : int option } - | Fetch of { cursor : string; limit : int option } - | Close of { cursor : string } + | Begin of {query: Drl.Ast.query; limit: int option} + | Fetch of {cursor: string; limit: int option} + | Close of {cursor: string} [@@deriving sexp] diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml index e40fde6..5fadc6d 100644 --- a/lib/scl/executor.ml +++ b/lib/scl/executor.ml @@ -1,20 +1,14 @@ let default_batch = 50 -type cursor_batch = { - cursor_id : string; - rows : Tuple.materialized list; - has_more : bool; -} - -type exec_result = - | Batch of cursor_batch - | Closed of Sublanguage_types.transition_delta +type cursor_batch = {cursor_id: string; rows: Tuple.materialized list; has_more: bool} +type exec_result = Batch of cursor_batch | Closed of Sublanguage_types.transition_delta module Make (NT : Nt.S) = struct module DrlExec = Drl.Executor.Make (NT) module Error = struct open Condition + (* TODO: more structure *) let cursor_error msg = condition "cursor-error" msg empty end @@ -25,10 +19,8 @@ module Make (NT : Nt.S) = struct (exec_result, Condition.t) result = ignore default_batch; match stmt with - | Ast.Begin _ -> - Error (Error.cursor_error "cursors not yet implemented") - | Ast.Fetch _ -> - Error (Error.cursor_error "cursors not yet implemented") + | Ast.Begin _ -> Error (Error.cursor_error "cursors not yet implemented") + | Ast.Fetch _ -> Error (Error.cursor_error "cursors not yet implemented") | Ast.Close _ -> let* () = Ok () in Ok (Closed ctx.branch#multigroups) diff --git a/lib/scl/parser.ml b/lib/scl/parser.ml index 53719ee..670139b 100644 --- a/lib/scl/parser.ml +++ b/lib/scl/parser.ml @@ -1,11 +1,11 @@ module Error = struct open Condition + let parse_error msg = condition "parse-error" msg empty end let validate = function - | (Ast.Begin { limit = Some limit; _ } | Ast.Fetch { limit = Some limit; _ }) - when limit <= 0 -> + | (Ast.Begin {limit= Some limit; _} | Ast.Fetch {limit= Some limit; _}) when limit <= 0 -> Error (Error.parse_error "The provision of `limit` is expected to be positive.") | stmt -> Ok stmt diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index 0793211..526e7a2 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -6,13 +6,12 @@ module Make (NT : Nt.S) = struct let name = "scl" let parse _ = Ok () - let parse_sexp sexp = Parser.of_sexp sexp let execute ctx ast = Exec.execute ctx ast |> Result.map (function - | Executor.Batch { cursor_id; rows; has_more } -> - Sublanguage_types.Cursor { cursor_id; rows; has_more } - | Executor.Closed delta -> Sublanguage_types.Transition delta) + | Executor.Batch {cursor_id; rows; has_more} -> + Sublanguage_types.Cursor {cursor_id; rows; has_more} + | Executor.Closed delta -> Sublanguage_types.Transition delta ) end diff --git a/lib/session.ml b/lib/session.ml index 5505e7e..cac181f 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -4,46 +4,41 @@ DDL / DML / DRL sublanguages operate through that branch. *) module Make (NT : Nt.S) = struct - module B = Branch.Make (NT) let ( let* ) = Result.bind - class session - ~(sid : string) - ~(branch : B.branch) = - object - val mutable br : B.branch = branch - - method id = sid - method branch = br - method snapshot = br#tip - method tip = br#tip + class session ~(sid : string) ~(branch : B.branch) = + object + val mutable br : B.branch = branch + method id = sid + method branch = br + method snapshot = br#tip + method tip = br#tip - (* Switch to a different branch within the same session. *) - method set_branch (b : B.branch) = br <- b + (* Switch to a different branch within the same session. *) + method set_branch (b : B.branch) = br <- b - method close () = - let* () = br#close () in - NT.session_close sid - end + method close () = + let* () = br#close () in + NT.session_close sid + end (* Open a session on a live (mutable) branch. Creates the branch if it does not exist yet. *) let open_session claims ~branch_name = - let* sid = NT.session_open () in + let* sid = NT.session_open () in let* branch = B.open_branch claims branch_name in Ok (new session ~sid ~branch) (* Open a session pinned to a specific snapshot hash (detached / read-only). Mutations through the returned branch are refused. *) let open_snapshot_session claims ~branch_name ~snapshot_hash = - let* sid = NT.session_open () in + let* sid = NT.session_open () in let* branch = B.open_snapshot claims ~branch_name ~snapshot_hash in (* Inform RNT of the session's snapshot override so future session-path resolution (once NamespaceReferenceManager handles /system/sessions/...) can route queries through the pinned snapshot. *) - let* () = NT.session_set_branch sid branch_name snapshot_hash in + let* () = NT.session_set_branch sid branch_name snapshot_hash in Ok (new session ~sid ~branch) - end diff --git a/lib/storable.ml b/lib/storable.ml index 5527044..7c02732 100644 --- a/lib/storable.ml +++ b/lib/storable.ml @@ -4,28 +4,27 @@ module Wire = struct | None -> None | Some index -> Some - ( String.sub value 0 index, - String.sub value (index + 1) (String.length value - index - 1) ) + (String.sub value 0 index, String.sub value (index + 1) (String.length value - index - 1)) let lines bytes = - bytes |> Bytes.to_string |> String.split_on_char '\n' + bytes + |> Bytes.to_string + |> String.split_on_char '\n' |> List.filter (fun line -> String.trim line <> "") let fields bytes = lines bytes |> List.filter_map (fun line -> split_once '=' line) - |> List.map (fun (key, value) -> (String.trim key, String.trim value)) + |> List.map (fun (key, value) -> String.trim key, String.trim value) let require_type expected fields = match List.assoc_opt "type" fields with | Some actual when actual = expected -> () | Some actual -> - invalid_arg - (Printf.sprintf "expected storable type %S, got %S" expected actual) + invalid_arg (Printf.sprintf "expected storable type %S, got %S" expected actual) | None -> invalid_arg "missing storable type" - let values key fields = - List.filter_map (fun (k, v) -> if k = key then Some v else None) fields + let values key fields = List.filter_map (fun (k, v) -> if k = key then Some v else None) fields let required key fields = match List.assoc_opt key fields with @@ -40,56 +39,51 @@ module Wire = struct let encode fields = fields |> List.map (fun (key, value) -> key ^ "=" ^ value) - |> String.concat "\n" |> fun value -> Bytes.of_string (value ^ "\n") + |> String.concat "\n" + |> fun value -> Bytes.of_string (value ^ "\n") end module Tuple = struct - type t = { relation : string; attributes : (string * string) list } + type t = {relation: string; attributes: (string * string) list} let to_bytes tuple = Wire.encode - ([ ("type", "tuple"); ("relation", tuple.relation) ] - @ List.map - (fun (name, value) -> ("attribute", name ^ ":" ^ value)) - tuple.attributes) + ( ["type", "tuple"; "relation", tuple.relation] + @ List.map (fun (name, value) -> "attribute", name ^ ":" ^ value) tuple.attributes ) let of_bytes bytes = let fields = Wire.fields bytes in Wire.require_type "tuple" fields; - { - relation = Wire.required "relation" fields; - attributes = List.map Wire.attribute (Wire.values "attribute" fields); - } + { relation= Wire.required "relation" fields; + attributes= List.map Wire.attribute (Wire.values "attribute" fields) } end module Relation = struct - type t = { - name : string; - schema : (string * string) list; - (** Hex Merkle root of the relation's tuple set. Empty string = empty relation. *) - tree_pointer : string; - } + type t = + { name: string; + schema: (string * string) list; + (** Hex Merkle root of the relation's tuple set. Empty string = empty + relation. *) + tree_pointer: string } let to_bytes relation = Wire.encode - ([ ("type", "relation"); ("name", relation.name); ("kind", "stored"); - ("tree_pointer", relation.tree_pointer) ] - @ List.map - (fun (name, domain) -> ("attribute", name ^ ":" ^ domain)) - relation.schema) + ( [ "type", "relation"; + "name", relation.name; + "kind", "stored"; + "tree_pointer", relation.tree_pointer ] + @ List.map (fun (name, domain) -> "attribute", name ^ ":" ^ domain) relation.schema ) let of_bytes bytes = let fields = Wire.fields bytes in Wire.require_type "relation" fields; - { - name = Wire.required "name" fields; - schema = List.map Wire.attribute (Wire.values "attribute" fields); - tree_pointer = Option.value (List.assoc_opt "tree_pointer" fields) ~default:""; - } + { name= Wire.required "name" fields; + schema= List.map Wire.attribute (Wire.values "attribute" fields); + tree_pointer= Option.value (List.assoc_opt "tree_pointer" fields) ~default:"" } end module Multigroup = struct - type t = { name : string; relations : Relation.t list } + type t = {name: string; relations: Relation.t list} (* Wire format: "name|attr1:dom1,attr2:dom2|<merkle_root>" The third segment is the Merkle root hex; empty string = empty relation. @@ -107,31 +101,25 @@ module Multigroup = struct let parse_relation value = match Wire.split_once '|' value with - | None -> { Relation.name = value; schema = []; tree_pointer = "" } + | None -> {Relation.name= value; schema= []; tree_pointer= ""} | Some (name, rest) -> let attrs_str, tree_pointer = - match Wire.split_once '|' rest with - | None -> (rest, "") - | Some (a, tp) -> (a, tp) + match Wire.split_once '|' rest with None -> rest, "" | Some (a, tp) -> a, tp in let schema = if attrs_str = "" then [] else attrs_str |> String.split_on_char ',' |> List.map Wire.attribute in - { Relation.name; schema; tree_pointer } + {Relation.name; schema; tree_pointer} let to_bytes multigroup = Wire.encode - ([ ("type", "multigroup"); ("name", multigroup.name) ] - @ List.map - (fun relation -> ("relation", relation_value relation)) - multigroup.relations) + ( ["type", "multigroup"; "name", multigroup.name] + @ List.map (fun relation -> "relation", relation_value relation) multigroup.relations ) let of_bytes bytes = let fields = Wire.fields bytes in Wire.require_type "multigroup" fields; - { - name = Wire.required "name" fields; - relations = List.map parse_relation (Wire.values "relation" fields); - } + { name= Wire.required "name" fields; + relations= List.map parse_relation (Wire.values "relation" fields) } end diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml index e5846ed..db66b27 100644 --- a/lib/sublanguage.ml +++ b/lib/sublanguage.ml @@ -1,4 +1,3 @@ -include Sublanguage_types (** Effect classification for sublanguage operations. Categorically: @@ -15,6 +14,7 @@ include Sublanguage_types (Turing-complete; breaks the termination guarantee of DRL) - ACL -> a functor restriction: narrows the admissible natural transformations based on authorization context *) +include Sublanguage_types module type S = sig include Configuration.CONFIGURABLE @@ -23,6 +23,5 @@ module type S = sig val name : string val parse_sexp : Sexplib.Sexp.t -> (ast, Condition.t) Result.t - val execute : Sublanguage_context.t -> ast -> (result, Condition.t) Result.t end diff --git a/lib/sublanguage_context.ml b/lib/sublanguage_context.ml index 40aa543..df537a7 100644 --- a/lib/sublanguage_context.ml +++ b/lib/sublanguage_context.ml @@ -1,46 +1,40 @@ (** Execution context passed to every sublanguage. - - [write_handle] NT branch handle; sublanguages use it for mutations - (create_relation, link_tuple, etc). Read-only - sublanguages (DRL) ignore it. + - [write_handle] NT branch handle; sublanguages use it for mutations + (create_relation, link_tuple, etc). Read-only sublanguages (DRL) ignore + it. - - [branch] Structural view over the active branch — gives every - executor random-access to every multigroup bound to - the branch via [mg_of]. Schema lookups for an FQN - [{mg; name}] use [branch#mg_of mg |> Option.bind - (fun m -> m#get_relation name)]. + - [branch] Structural view over the active branch — gives every executor + random-access to every multigroup bound to the branch via [mg_of]. Schema + lookups for an FQN [{mg; name}] use + [branch#mg_of mg |> Option.bind (fun m -> m#get_relation name)]. - - [resolve] Builds an absolute RNT path for an FQN. Pass - [~branch:b] to address a relation on a different - live branch (cross-multigroup reads). + - [resolve] Builds an absolute RNT path for an FQN. Pass [~branch:b] to + address a relation on a different live branch (cross-multigroup reads). - - [switch_branch] Closes the current branch and opens the named one, - returning the delta describing the new branch's mg - set. Provided by the listener so VCL does not need - direct access to session state. *) + - [switch_branch] Closes the current branch and opens the named one, + returning the delta describing the new branch's mg set. Provided by the + listener so VCL does not need direct access to session state. *) -type branch_view = < - name : string; - tip : string; - mg_of : string -> Management.Multigroup.multigroup option; - multigroups : (string * Management.Multigroup.multigroup) list; - add_multigroup : name:string -> unit; - set_mg : name:string -> - Management.Multigroup.multigroup -> unit; - path : ?branch:string -> Qualified_name.t -> string; -> +type branch_view = + < name: string + ; tip: string + ; mg_of: string -> Management.Multigroup.multigroup option + ; multigroups: (string * Management.Multigroup.multigroup) list + ; add_multigroup: name:string -> unit + ; set_mg: name:string -> Management.Multigroup.multigroup -> unit + ; path: ?branch:string -> Qualified_name.t -> string > -type t = { - write_handle : Nt.branch_handle; - branch : branch_view; - resolve : ?branch:string -> Qualified_name.t -> string; - switch_branch : string -> - (Sublanguage_types.transition_delta, Condition.t) result; - session_hash : string; - (** RNT session hash owning this connection. Session-scoped ephemeral - relations (with DML [Define]) register under - /system/sessions/<session_hash>/ephemeral/<name>. *) -} +type t = + { write_handle: Nt.branch_handle; + branch: branch_view; + resolve: ?branch:string -> Qualified_name.t -> string; + switch_branch: string -> (Sublanguage_types.transition_delta, Condition.t) result; + session_hash: string + (** RNT session hash owning this connection. Session-scoped ephemeral + relations (with DML [Define]) register under + /system/sessions/<session_hash>/ephemeral/<name>. *) + } (** Absolute RNT path of a session-scoped ephemeral relation. An unqualified name in a DRL [Base] resolves here: named bindings shadow nothing since @@ -52,30 +46,24 @@ module Make (NT : Nt.S) = struct module Session = Session.Make (NT) module Branch = Branch.Make (NT) - let make_ctx - (session : Session.session) - (claims : string) - : t = + let make_ctx (session : Session.session) (claims : string) : t = let br = session#branch in - { - write_handle = br#branch_handle; - branch = (br :> branch_view); - resolve = br#path; - session_hash = session#id; - switch_branch = fun name -> - match br#close () with - | Error e -> Error e - | Ok () -> - begin match Branch.open_branch claims name with - | Error e -> - begin match Branch.open_branch claims "master" with - | Ok mbr -> session#set_branch mbr - | Error _ -> () - end; - Error e - | Ok new_br -> - session#set_branch new_br; - Ok new_br#multigroups - end - } + { write_handle= br#branch_handle; + branch= (br :> branch_view); + resolve= br#path; + session_hash= session#id; + switch_branch= + (fun name -> + match br#close () with + | Error e -> Error e + | Ok () -> + begin match Branch.open_branch claims name with + | Error e -> + begin match Branch.open_branch claims "master" with + | Ok mbr -> session#set_branch mbr + | Error _ -> () + end; + Error e + | Ok new_br -> session#set_branch new_br; Ok new_br#multigroups + end ) } end diff --git a/lib/sublanguage_types.ml b/lib/sublanguage_types.ml index 3d2b5cc..a8d6077 100644 --- a/lib/sublanguage_types.ml +++ b/lib/sublanguage_types.ml @@ -1,11 +1,7 @@ -type cursor_result = { - cursor_id : string; - rows : Tuple.materialized list; - has_more : bool; -} +type cursor_result = {cursor_id: string; rows: Tuple.materialized list; has_more: bool} -(** A Transition delta names every multigroup that the statement touched and - the updated value for each. Most statements yield a single-element list; +(** A Transition delta names every multigroup that the statement touched and the + updated value for each. Most statements yield a single-element list; VCL/SCL/ICL statements may touch more than one. *) type transition_delta = (string * Management.Multigroup.multigroup) list diff --git a/lib/system.ml b/lib/system.ml index 56a5440..16c3b42 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -1,55 +1,46 @@ -(** System assembly: registry-based configuration dispatch. - This module is the composition root. It owns the mapping from configuration - tags to concrete implementations and assembles a server from a config file. *) +(** System assembly: registry-based configuration dispatch. This module is the + composition root. It owns the mapping from configuration tags to concrete + implementations and assembles a server from a config file. *) type nt_parcel = NtParcel : (module Nt.S) -> nt_parcel type transport_parcel = - | TransportParcel : - (module Transport.TRANSPORT with type t = 't) * 't - -> transport_parcel + | TransportParcel : (module Transport.TRANSPORT with type t = 't) * 't -> transport_parcel -type nt_provider = Sexplib.Sexp.t -> (nt_parcel, Condition.t) result +type nt_provider = Sexplib.Sexp.t -> (nt_parcel, Condition.t) result type transport_provider = Sexplib.Sexp.t -> (transport_parcel, Condition.t) result -type registry = { - nt : nt_provider Utilities.StringMap.t; - transport : transport_provider Utilities.StringMap.t; -} +type registry = + {nt: nt_provider Utilities.StringMap.t; transport: transport_provider Utilities.StringMap.t} module Error = struct open Condition - let unknown_backend component tag = condition "unknown-backend" "Unknown backend for component" - ("component" |=| (of_string component) & - "tag" |=| (of_string tag)) + + let unknown_backend component tag = + condition "unknown-backend" "Unknown backend for component" + ("component" |=| of_string component & "tag" |=| of_string tag) end let registry : registry = let open Utilities.StringMap in - { - nt = + { nt= empty - |> add "memory" (fun _sexp -> - Ok (NtParcel (module Nt.Memory : Nt.S))) + |> add "memory" (fun _sexp -> Ok (NtParcel (module Nt.Memory : Nt.S))) |> add "sqlite" (fun sexp -> (* Accept (sqlite) for :memory: or (sqlite "/path/to/db") for a file. *) - let path = match sexp with - | Sexplib.Sexp.(List [ Atom p ]) -> p - | _ -> ":memory:" - in + let path = match sexp with Sexplib.Sexp.(List [Atom p]) -> p | _ -> ":memory:" in let module M = Nt.Make (struct - let driver = "sqlite" + let driver = "sqlite" let init_arg = path end) in - Ok (NtParcel (module M : Nt.S))); - transport = + Ok (NtParcel (module M : Nt.S)) ); + 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))); - } + Ok (TransportParcel ((module Transport.TCP), transport)) ) } let assemble (config : Configuration.t) : (unit -> unit, Condition.t) result = let open Utilities.Result in @@ -60,20 +51,17 @@ let assemble (config : Configuration.t) : (unit -> unit, Condition.t) result = in let* nt_provider = Utilities.StringMap.find_opt nt_tag registry.nt - |> Option.to_result - ~none:(Error.unknown_backend "nt" nt_tag) + |> Option.to_result ~none:(Error.unknown_backend "nt" nt_tag) in let* packed_nt = nt_provider nt_body in let* transport_tag, transport_body = Configuration.require_section ~name:"transport" - ~valid_tags: - (Utilities.StringMap.bindings registry.transport |> List.map fst) + ~valid_tags:(Utilities.StringMap.bindings registry.transport |> List.map fst) config in let* transport_provider = Utilities.StringMap.find_opt transport_tag registry.transport - |> Option.to_result - ~none:(Error.unknown_backend "transport" transport_tag) + |> Option.to_result ~none:(Error.unknown_backend "transport" transport_tag) in let* packed_transport = transport_provider transport_body in let (NtParcel (module NT)) = packed_nt in @@ -84,7 +72,5 @@ let assemble (config : Configuration.t) : (unit -> unit, Condition.t) result = let run_from_config (path : string) : (unit -> unit, Condition.t) result = let ( let* ) = Result.bind in - let* config = - Configuration.load ~expected_keys:[ "nt"; "transport" ] path - in + let* config = Configuration.load ~expected_keys:["nt"; "transport"] path in assemble config diff --git a/lib/transport.ml b/lib/transport.ml index 4ed9743..b40f6c5 100644 --- a/lib/transport.ml +++ b/lib/transport.ml @@ -12,16 +12,13 @@ module type TRANSPORT = sig end module TCP : TRANSPORT = struct - type configuration = { - address_family : Unix.socket_domain; - sockaddr : Unix.sockaddr; - } - + type configuration = {address_family: Unix.socket_domain; sockaddr: Unix.sockaddr} type t = Unix.file_descr type connection = Unix.file_descr module Error = struct open Condition + (* TODO: more structure *) let parse_error msg = condition "parse-error" msg empty end @@ -29,30 +26,26 @@ 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); - } - | `Unix path -> - Ok { address_family = Unix.PF_UNIX; sockaddr = Unix.ADDR_UNIX path } + { 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} 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") - | 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 "path"; Atom p ] :: rest -> go addr port (Some p) rest + 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 "path"; Atom p] :: rest -> go addr port (Some p) rest | bad :: _ -> errorf "transport/tcp: unexpected: %s" (to_string bad) in match sexp with @@ -60,11 +53,10 @@ module TCP : TRANSPORT = struct | _ -> Error (Error.parse_error "transport/tcp: expected a list of fields") let string_of_sockaddr = function - | Unix.ADDR_INET (host, port) -> - Printf.sprintf "%s:%d" (Unix.string_of_inet_addr host) port + | Unix.ADDR_INET (host, port) -> Printf.sprintf "%s:%d" (Unix.string_of_inet_addr host) port | Unix.ADDR_UNIX path -> path - let create { address_family; sockaddr } = + let create {address_family; sockaddr} = let socket = Unix.socket address_family Unix.SOCK_STREAM 0 in Unix.setsockopt socket Unix.SO_REUSEADDR true; Unix.bind socket sockaddr; @@ -72,8 +64,7 @@ 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/tuple.ml b/lib/tuple.ml index ffeb3c9..1f47214 100644 --- a/lib/tuple.ml +++ b/lib/tuple.ml @@ -3,35 +3,24 @@ module AttributeMap = struct let sexp_of_t sexp_of_v m = Sexplib.Sexp.List - (List.map - (fun (k, v) -> Sexplib.Sexp.List [ Sexplib.Sexp.Atom k; sexp_of_v v ]) - (bindings m)) + (List.map (fun (k, v) -> Sexplib.Sexp.List [Sexplib.Sexp.Atom k; sexp_of_v v]) (bindings m)) end -type non_materialized = { - hash : Conventions.Hash.t; - relation : Conventions.Name.t; - attributes : Attribute.referenced AttributeMap.t; - (* lineage : Relation.Lineage.t option; *) -} +type non_materialized = + { hash: Conventions.Hash.t; + relation: Conventions.Name.t; + attributes: Attribute.referenced AttributeMap.t (* lineage : Relation.Lineage.t option; *) } [@@deriving sexp_of] -type materialized = { - relation : Conventions.Name.t; - attributes : Attribute.materialized AttributeMap.t; - (* lineage : Relation.Lineage.t option; *) -} +type materialized = + { relation: Conventions.Name.t; + attributes: Attribute.materialized AttributeMap.t (* lineage : Relation.Lineage.t option; *) } [@@deriving sexp_of] -type t = Materialized of materialized | NonMaterialized of non_materialized -[@@deriving sexp_of] +type t = Materialized of materialized | NonMaterialized of non_materialized [@@deriving sexp_of] let make_materialized ~relation ~attributes = - Materialized { - relation; - attributes; - (* lineage = None *) - } + Materialized {relation; attributes (* lineage = None *)} let materialized_equal a b = AttributeMap.equal Attribute.materialized_equal a.attributes b.attributes diff --git a/lib/utilities.ml b/lib/utilities.ml index 7b77da9..7e47d2e 100644 --- a/lib/utilities.ml +++ b/lib/utilities.ml @@ -16,9 +16,7 @@ let print_with_time str = let orange = "\027[38;5;208m" in let reset = "\027[0m" in let formatted_time = - Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.Unix.tm_year + 1900) - (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min - tm.Unix.tm_sec + Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) + tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in - print_endline - @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str + print_endline @@ Printf.sprintf "%s[%s]%s %s" orange formatted_time reset str diff --git a/lib/vcl/executor.ml b/lib/vcl/executor.ml index 4ac5eff..ff95583 100644 --- a/lib/vcl/executor.ml +++ b/lib/vcl/executor.ml @@ -3,9 +3,7 @@ module Make (NT : Nt.S) = struct (Sublanguage_types.result, Condition.t) result = match stmt with | Ast.Use branch_name -> - Result.map - (fun delta -> Sublanguage_types.Transition delta) - (ctx.switch_branch branch_name) + Result.map (fun delta -> Sublanguage_types.Transition delta) (ctx.switch_branch branch_name) let _ = (module NT : Nt.S) end diff --git a/lib/vcl/sublanguage.ml b/lib/vcl/sublanguage.ml index 4319eb8..437c93b 100644 --- a/lib/vcl/sublanguage.ml +++ b/lib/vcl/sublanguage.ml @@ -1,7 +1,9 @@ module Make (NT : Nt.S) = struct module Error = struct open Condition - let unrecognized_command expr = condition "unrecognized-command" "Unrecognized command" ("expression" |=| (of_sexp expr)) + + let unrecognized_command expr = + condition "unrecognized-command" "Unrecognized command" ("expression" |=| of_sexp expr) end module Exec = Executor.Make (NT) @@ -13,9 +15,8 @@ module Make (NT : Nt.S) = struct let parse _ = Ok () let parse_sexp = function - | Sexplib.Sexp.(List [ Atom "use"; Atom branch ]) -> Ok (Ast.Use branch) - | sexp -> - Error (Error.unrecognized_command sexp) + | Sexplib.Sexp.(List [Atom "use"; Atom branch]) -> Ok (Ast.Use branch) + | sexp -> Error (Error.unrecognized_command sexp) let execute = Exec.execute end |
