diff options
Diffstat (limited to 'lib')
47 files changed, 1483 insertions, 1450 deletions
diff --git a/lib/algebra.ml b/lib/algebra.ml index a1970bd..30ed1a6 100644 --- a/lib/algebra.ml +++ b/lib/algebra.ml @@ -1,39 +1,40 @@ -type error = - | StorageError of string - | GeneratorError of string +type error = StorageError of string | GeneratorError of string + +module Make (Storage : Management.Physical.S) = struct + module Ops = Manipulation.Make (Storage) -module Make(Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) type storage = Storage.t (* Internal generator utilities *) let rec list_generator : Tuple.t list -> Generator.t = function - | [] -> (fun _pos -> Generator.Done) - | t :: rest -> (fun _pos -> Generator.Value (t, list_generator rest)) + | [] -> fun _pos -> Generator.Done + | t :: rest -> fun _pos -> Generator.Value (t, list_generator rest) let drain gen = let rec go gen pos acc = match gen (Some pos) with - | Generator.Done -> Ok (List.rev acc) - | Generator.Error e -> Error (GeneratorError e) + | Generator.Done -> Ok (List.rev acc) + | Generator.Error e -> Error (GeneratorError e) | Generator.Value (t, next) -> go next (pos + 1) (t :: acc) - in go gen 0 [] + in + go gen 0 [] let to_generator (storage : storage) (rel : Relation.t) : Generator.t = match rel.Relation.generator with | Some gen -> gen - | None -> - (* TODO: Avoid materializing all tuple hashes/tuples at once. + | None -> ( + (* TODO: Avoid materializing all tuple hashes/tuples at once. Current implementation calls tuple_hashes rel which loads all hashes into memory, then load_tuples which loads all tuples. This defeats lazy evaluation and scales badly (fails for billions of tuples). Replace with paginated tuple_hashes or Merkle streaming to load hashes/tuples on demand in chunks. *) - let hashes = Ops.tuple_hashes rel in - (match Ops.load_tuples storage hashes with - | Error _ -> (fun _pos -> Generator.Error ("Failed to load: " ^ rel.Relation.name)) - | Ok ts -> list_generator (List.map (fun t -> Tuple.Materialized t) ts)) + let hashes = Ops.tuple_hashes rel in + match Ops.load_tuples storage hashes with + | Error _ -> + fun _pos -> Generator.Error ("Failed to load: " ^ rel.Relation.name) + | Ok ts -> list_generator (List.map (fun t -> Tuple.Materialized t) ts)) let of_generator ~name ~schema ?constraints ?cardinality gen = let cardinality = @@ -41,22 +42,24 @@ module Make(Storage : Management.Physical.S) = struct | Some c -> c | None -> Conventions.Cardinality.AlephZero in - Relation.make - ~hash:None ~name ~schema ~tree:None ~constraints - ~cardinality + Relation.make ~hash:None ~name ~schema ~tree:None ~constraints ~cardinality ~generator:(Some gen) ~membership_criteria:(fun _ -> true) ~provenance:Relation.Provenance.Undefined ~lineage:(Relation.Lineage.Base "derived") - let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : Relation.t = - let attrs = List.fold_left (fun acc (k, v) -> - Tuple.AttributeMap.add k { Attribute.value = v } acc) - Tuple.AttributeMap.empty pairs + let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : + Relation.t = + let attrs = + List.fold_left + (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 schema = List.map (fun (k, _) -> (k, "abstract")) pairs in - of_generator ~name:"const" ~schema (list_generator [tuple]) + of_generator ~name:"const" ~schema (list_generator [ tuple ]) (* Operators *) @@ -65,141 +68,181 @@ module Make(Storage : Management.Physical.S) = struct let lazy_gen = let rec go g pos = match g pos with - | Generator.Done -> Generator.Done + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> - if predicate t then Generator.Value (t, go next) - else go next (Option.map ((+) 1) pos) - in fun pos -> go gen pos + if predicate t then Generator.Value (t, go next) + else go next (Option.map (( + ) 1) pos) + in + fun pos -> go gen pos in - Ok (of_generator ~name:("σ_" ^ rel.Relation.name) ~schema:rel.Relation.schema - ?constraints:rel.Relation.constraints lazy_gen) + Ok + (of_generator + ~name:("σ_" ^ rel.Relation.name) + ~schema:rel.Relation.schema ?constraints:rel.Relation.constraints + lazy_gen) let project storage (attrs : string list) rel = let gen = to_generator storage rel in let project_tuple = function | Tuple.Materialized t -> - let attrs' = List.fold_left (fun acc k -> - match Tuple.AttributeMap.find_opt k t.Tuple.attributes with - | None -> acc - | Some v -> Tuple.AttributeMap.add k v acc) - Tuple.AttributeMap.empty attrs in - Tuple.Materialized { t with attributes = attrs' } + let attrs' = + List.fold_left + (fun acc k -> + match Tuple.AttributeMap.find_opt k t.Tuple.attributes with + | None -> acc + | Some v -> Tuple.AttributeMap.add k v acc) + Tuple.AttributeMap.empty attrs + in + Tuple.Materialized { t with attributes = attrs' } | other -> other in - let new_schema = List.filter (fun (n, _) -> List.mem n attrs) rel.Relation.schema in + let new_schema = + List.filter (fun (n, _) -> List.mem n attrs) rel.Relation.schema + in let lazy_gen = - let rec go g pos = match g pos with - | Generator.Done -> Generator.Done + let rec go g pos = + match g pos with + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> Generator.Value (project_tuple t, go next) - in fun pos -> go gen pos + in + fun pos -> go gen pos in let filtered_constraints = match rel.Relation.constraints with | None | Some [] -> None - | Some cs -> - let kept = - List.filter_map - (fun (name, c) -> - match Constraint.filter_by_attrs attrs c with - | Some c' -> Some (name, c') - | None -> None) - cs - in - (match kept with [] -> None | _ -> Some kept) + | Some cs -> ( + let kept = + List.filter_map + (fun (name, c) -> + match Constraint.filter_by_attrs attrs c with + | Some c' -> Some (name, c') + | None -> None) + cs + in + match kept with [] -> None | _ -> Some kept) in - Ok (of_generator ~name:("π_" ^ rel.Relation.name) ~schema:new_schema - ?constraints:filtered_constraints lazy_gen) + Ok + (of_generator + ~name:("π_" ^ rel.Relation.name) + ~schema:new_schema ?constraints:filtered_constraints lazy_gen) let rename storage (renames : (string * string) list) rel = - let rename_key k = match List.assoc_opt k renames with Some k' -> k' | None -> k in + let rename_key k = + match List.assoc_opt k renames with Some k' -> k' | None -> k + in let rename_tuple = function | Tuple.Materialized t -> - let attrs' = Tuple.AttributeMap.fold (fun k v acc -> - Tuple.AttributeMap.add (rename_key k) v acc) - t.Tuple.attributes Tuple.AttributeMap.empty in - Tuple.Materialized { t with attributes = attrs' } + let attrs' = + Tuple.AttributeMap.fold + (fun k v acc -> Tuple.AttributeMap.add (rename_key k) v acc) + t.Tuple.attributes Tuple.AttributeMap.empty + in + Tuple.Materialized { t with attributes = attrs' } | other -> other in let gen = to_generator storage rel in - let new_schema = List.map (fun (n, d) -> (rename_key n, d)) rel.Relation.schema in + let new_schema = + List.map (fun (n, d) -> (rename_key n, d)) rel.Relation.schema + in let lazy_gen = - let rec go g pos = match g pos with - | Generator.Done -> Generator.Done + let rec go g pos = + match g pos with + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> Generator.Value (rename_tuple t, go next) - in fun pos -> go gen pos + in + fun pos -> go gen pos in let renamed_constraints = match rel.Relation.constraints with | None | Some [] -> None | Some cs -> - Some - (List.map - (fun (name, c) -> (name, Constraint.rename_vars renames c)) - cs) + Some + (List.map + (fun (name, c) -> (name, Constraint.rename_vars renames c)) + cs) in - Ok (of_generator ~name:("ρ_" ^ rel.Relation.name) ~schema:new_schema - ?constraints:renamed_constraints lazy_gen) + Ok + (of_generator + ~name:("ρ_" ^ rel.Relation.name) + ~schema:new_schema ?constraints:renamed_constraints lazy_gen) let equijoin storage (attrs : string list) left right = let right_gen = to_generator storage right in match drain right_gen with | Error e -> Error e | Ok right_tuples -> - let left_gen = to_generator storage left in - let get_vals attr_list = function - | Tuple.Materialized t -> - List.map (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) attr_list - | _ -> List.map (fun _ -> None) attr_list - in - let merge lt rt = match lt, rt with - | Tuple.Materialized l, Tuple.Materialized r -> - Tuple.Materialized { l with attributes = - Tuple.AttributeMap.union (fun _ a _ -> Some a) - l.Tuple.attributes r.Tuple.attributes } - | _ -> lt - in - let merged_schema = - left.Relation.schema @ - List.filter (fun (n, _) -> - not (List.mem n attrs) && - not (List.exists (fun (m, _) -> m = n) left.Relation.schema)) - right.Relation.schema - in - let join_gen = - let rec chain_with_cont g cont pos = - match g pos with - | Generator.Done -> cont pos - | Generator.Value (t, next) -> Generator.Value (t, fun p -> chain_with_cont next cont p) - | Generator.Error e -> Generator.Error e + let left_gen = to_generator storage left in + let get_vals attr_list = function + | Tuple.Materialized t -> + List.map + (fun a -> Tuple.AttributeMap.find_opt a t.Tuple.attributes) + attr_list + | _ -> List.map (fun _ -> None) attr_list in - let rec from_left lgen lpos = - fun pos -> - match lgen (Some lpos) with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (lt, next_left) -> - let lv = get_vals attrs lt in - let matches = List.filter_map (fun rt -> - if get_vals attrs rt = lv then Some (merge lt rt) else None) right_tuples in - (match matches with - | [] -> from_left next_left (lpos + 1) pos - | _ -> - chain_with_cont (list_generator matches) - (from_left next_left (lpos + 1)) pos) + let merge lt rt = + match (lt, rt) with + | Tuple.Materialized l, Tuple.Materialized r -> + Tuple.Materialized + { + l with + attributes = + Tuple.AttributeMap.union + (fun _ a _ -> Some a) + l.Tuple.attributes r.Tuple.attributes; + } + | _ -> lt in - from_left left_gen 0 - in - let merged_constraints = - match left.Relation.constraints, right.Relation.constraints with - | None, None -> None - | Some cs, None | None, Some cs -> Some cs - | Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2) - in - let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in - Ok (of_generator ~name ~schema:merged_schema + let merged_schema = + left.Relation.schema + @ List.filter + (fun (n, _) -> + (not (List.mem n attrs)) + && not (List.exists (fun (m, _) -> m = n) left.Relation.schema)) + right.Relation.schema + in + let join_gen = + let rec chain_with_cont g cont pos = + match g pos with + | Generator.Done -> cont pos + | Generator.Value (t, next) -> + Generator.Value (t, fun p -> chain_with_cont next cont p) + | Generator.Error e -> Generator.Error e + in + let rec from_left lgen lpos = + fun pos -> + match lgen (Some lpos) with + | Generator.Done -> Generator.Done + | Generator.Error e -> Generator.Error e + | Generator.Value (lt, next_left) -> ( + let lv = get_vals attrs lt in + let matches = + List.filter_map + (fun rt -> + if get_vals attrs rt = lv then Some (merge lt rt) + else None) + right_tuples + in + match matches with + | [] -> from_left next_left (lpos + 1) pos + | _ -> + chain_with_cont (list_generator matches) + (from_left next_left (lpos + 1)) + pos) + in + from_left left_gen 0 + in + let merged_constraints = + match (left.Relation.constraints, right.Relation.constraints) with + | None, None -> None + | Some cs, None | None, Some cs -> Some cs + | Some cs1, Some cs2 -> Some (Constraint.merge cs1 cs2) + in + let name = "⋈_" ^ left.Relation.name ^ "_" ^ right.Relation.name in + Ok + (of_generator ~name ~schema:merged_schema ?constraints:merged_constraints join_gen) let union storage rel1 rel2 = @@ -208,47 +251,55 @@ module Make(Storage : Management.Physical.S) = struct let chain_gen = let rec go g1 g2 pos = match g1 pos with - | Generator.Done -> g2 pos + | Generator.Done -> g2 pos | Generator.Error _ -> g2 pos | Generator.Value (t, next) -> Generator.Value (t, fun p -> go next g2 p) - in fun pos -> go gen1 gen2 pos + in + fun pos -> go gen1 gen2 pos in let name = "∪_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in (* Conservative: drop constraints since they only hold if both inputs agree *) Ok (of_generator ~name ~schema:rel1.Relation.schema chain_gen) - let attrs_equal - (m1 : Attribute.materialized Tuple.AttributeMap.t) + let attrs_equal (m1 : Attribute.materialized Tuple.AttributeMap.t) (m2 : Attribute.materialized Tuple.AttributeMap.t) = Tuple.AttributeMap.equal - (fun a b -> Stdlib.(=) a.Attribute.value b.Attribute.value) m1 m2 + (fun a b -> Stdlib.( = ) a.Attribute.value b.Attribute.value) + m1 m2 let diff storage rel1 rel2 = let right_gen = to_generator storage rel2 in match drain right_gen with | Error e -> Error e | Ok right_tuples -> - let right_mats = List.filter_map (function - | Tuple.Materialized t -> Some t | _ -> None) right_tuples in - let left_gen = to_generator storage rel1 in - let not_in_right = function - | Tuple.Materialized t -> - not (List.exists (fun r -> - attrs_equal t.Tuple.attributes r.Tuple.attributes) right_mats) - | _ -> true - in - let lazy_gen = - let rec go g pos = - match g pos with - | Generator.Done -> Generator.Done - | Generator.Error e -> Generator.Error e - | Generator.Value (t, next) -> - if not_in_right t then Generator.Value (t, go next) - else go next (Option.map ((+) 1) pos) - in fun pos -> go left_gen pos - in - let name = "−_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in - Ok (of_generator ~name ~schema:rel1.Relation.schema + let right_mats = + List.filter_map + (function Tuple.Materialized t -> Some t | _ -> None) + right_tuples + in + let left_gen = to_generator storage rel1 in + let not_in_right = function + | Tuple.Materialized t -> + not + (List.exists + (fun r -> attrs_equal t.Tuple.attributes r.Tuple.attributes) + right_mats) + | _ -> true + in + let lazy_gen = + let rec go g pos = + match g pos with + | Generator.Done -> Generator.Done + | Generator.Error e -> Generator.Error e + | Generator.Value (t, next) -> + if not_in_right t then Generator.Value (t, go next) + else go next (Option.map (( + ) 1) pos) + in + fun pos -> go left_gen pos + in + let name = "−_" ^ rel1.Relation.name ^ "_" ^ rel2.Relation.name in + Ok + (of_generator ~name ~schema:rel1.Relation.schema ?constraints:rel1.Relation.constraints lazy_gen) let take storage n rel = @@ -256,22 +307,28 @@ module Make(Storage : Management.Physical.S) = struct let lazy_gen = let rec go g count pos = if count = 0 then Generator.Done - else match g pos with - | Generator.Done -> Generator.Done + else + match g pos with + | Generator.Done -> Generator.Done | Generator.Error e -> Generator.Error e | Generator.Value (t, next) -> Generator.Value (t, go next (count - 1)) - in fun pos -> go gen n pos + in + fun pos -> go gen n pos in - Ok (of_generator ~name:("τ_" ^ rel.Relation.name) ~schema:rel.Relation.schema - ?constraints:rel.Relation.constraints - ~cardinality:(Conventions.Cardinality.Finite n) lazy_gen) + Ok + (of_generator + ~name:("τ_" ^ rel.Relation.name) + ~schema:rel.Relation.schema ?constraints:rel.Relation.constraints + ~cardinality:(Conventions.Cardinality.Finite n) lazy_gen) let materialize storage rel : (Tuple.materialized list, error) Result.t = match drain (to_generator storage rel) with | Error e -> Error e | Ok tuples -> - Ok (List.filter_map (function Tuple.Materialized t -> Some t | _ -> None) tuples) - + Ok + (List.filter_map + (function Tuple.Materialized t -> Some t | _ -> None) + tuples) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/attribute.ml b/lib/attribute.ml index f3fc0b1..b828d64 100644 --- a/lib/attribute.ml +++ b/lib/attribute.ml @@ -1,15 +1,11 @@ type referenced = { value_hash : Conventions.Hash.t } [@@deriving sexp_of] +type materialized = { value : Conventions.AbstractValue.t } [@@deriving sexp_of] -type materialized = { value: Conventions.AbstractValue.t } [@@deriving sexp_of] - -type t = - | Referenced of referenced - | Materialized of materialized +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 }
\ No newline at end of file +let make_materialized ~value = Materialized { value } diff --git a/lib/conventions.ml b/lib/conventions.ml index 60069b0..b6f82a5 100644 --- a/lib/conventions.ml +++ b/lib/conventions.ml @@ -1,5 +1,6 @@ module Hash = struct type t = Interop.Sha256.t + let hash_text text = Interop.Sha256.compute_hash (Bytes.of_string text) let compare = String.compare let sexp_of_t = Sexplib.Std.sexp_of_string @@ -7,21 +8,25 @@ end module Name = struct type t = string + let sexp_of_t = Sexplib.Std.sexp_of_string end module Cardinality = struct type t = Finite of int | ConstrainedFinite | AlephZero | Continuum + let sexp_of_t = function - | Finite n -> Sexplib.Sexp.(List [Atom "Finite"; Atom (string_of_int n)]) + | Finite n -> Sexplib.Sexp.(List [ Atom "Finite"; Atom (string_of_int n) ]) | ConstrainedFinite -> Sexplib.Sexp.Atom "ConstrainedFinite" - | AlephZero -> Sexplib.Sexp.Atom "AlephZero" - | Continuum -> Sexplib.Sexp.Atom "Continuum" + | AlephZero -> Sexplib.Sexp.Atom "AlephZero" + | Continuum -> Sexplib.Sexp.Atom "Continuum" end module AbstractValue = struct type t = Obj.t - let hash (elem: t) = Interop.Sha256.compute_hash @@ Marshal.to_bytes elem [] + + let hash (elem : t) = Interop.Sha256.compute_hash @@ Marshal.to_bytes elem [] + let sexp_of_t (v : t) = let open Sexplib.Sexp in if Obj.is_int v then Atom (string_of_int (Obj.obj v : int)) @@ -33,4 +38,4 @@ module AbstractValue = struct if Float.is_nan f || Float.is_infinite f then Atom "nan" else Atom (string_of_float f) else Atom "<opaque>" -end
\ No newline at end of file +end diff --git a/lib/core_functions.ml b/lib/core_functions.ml index 39094cc..9cb6213 100644 --- a/lib/core_functions.ml +++ b/lib/core_functions.ml @@ -20,5 +20,4 @@ module Functions (F : Ctypes.FOREIGN) = struct let compute_hash = Foreign.foreign ~from:libmerklecpp "compute_hash" (ptr char @-> Ctypes.string @-> returning void) - end diff --git a/lib/dbms_language.ml b/lib/dbms_language.ml index 8d61aa3..47e5a99 100644 --- a/lib/dbms_language.ml +++ b/lib/dbms_language.ml @@ -1,39 +1,37 @@ (** Composable dispatch over sublanguages. - All commands must use the tagged envelope format: (tag payload) - where [tag] is the sublanguage name (drl, dml, ddl, icl, dcl, ...). - Adding a new sublanguage is just extending the list passed to [create]. *) + All commands must use the tagged envelope format: (tag payload) where [tag] + is the sublanguage name (drl, dml, ddl, icl, dcl, ...). Adding a new + sublanguage is just extending the list passed to [create]. *) module Make (Storage : Management.Physical.S with type error = string) = struct module type SubS = Sublanguage.S with type storage = Storage.t type dispatch_error = NoMatch of Sexplib.Sexp.t - type dispatch = (module SubS) list let create (langs : (module SubS) list) : dispatch = langs - let execute - (langs : dispatch) - (storage : Storage.t) - (db : Management.Database.t) - (input : string) - : (Sublanguage.result, dispatch_error) Result.t = - let no_match s = Error (NoMatch Sexplib.Sexp.(List [Atom "parse-error"; Atom s])) in + let execute (langs : dispatch) (storage : Storage.t) + (db : Management.Database.t) (input : string) : + (Sublanguage.result, dispatch_error) Result.t = + let no_match s = + Error (NoMatch Sexplib.Sexp.(List [ Atom "parse-error"; Atom s ])) + in match Envelope.parse input with | Error msg -> no_match msg - | Ok { tag; payload } -> - match List.find_opt (fun (module L : SubS) -> L.name = tag) langs with - | None -> no_match ("unknown sublanguage: " ^ tag) - | Some (module L) -> - match L.parse_sexp payload with - | Error e -> Error (NoMatch (L.sexp_of_error e)) - | Ok ast -> - match L.execute storage db ast with - | Ok result -> Ok result - | Error e -> Error (NoMatch (L.sexp_of_error e)) + | Ok { tag; payload } -> ( + match List.find_opt (fun (module L : SubS) -> L.name = tag) langs with + | None -> no_match ("unknown sublanguage: " ^ tag) + | Some (module L) -> ( + match L.parse_sexp payload with + | Error e -> Error (NoMatch (L.sexp_of_error e)) + | Ok ast -> ( + match L.execute storage db ast with + | Ok result -> Ok result + | Error e -> Error (NoMatch (L.sexp_of_error e))))) let sexp_of_dispatch_error (NoMatch sexp) = sexp end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml index e1dae13..0b6107f 100644 --- a/lib/dcl/ast.ml +++ b/lib/dcl/ast.ml @@ -4,10 +4,10 @@ type merge_strategy = PreferLeft | PreferRight | RevertToAncestor [@@deriving sexp] type statement = - | CreateBranch of { name: string; hash: string option [@sexp.option] } + | CreateBranch of { name : string; hash : string option [@sexp.option] } | Checkout of string | GetHead | GetBranchTip of string - | UpdateBranchTip of { name: string; hash: string } - | Merge of { left: string; right: string; strategy: merge_strategy } + | UpdateBranchTip of { name : string; hash : string } + | Merge of { left : string; right : string; strategy : merge_strategy } [@@deriving sexp] diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml index cf2cfed..8c2fbdc 100644 --- a/lib/dcl/executor.ml +++ b/lib/dcl/executor.ml @@ -1,94 +1,94 @@ module Make (Storage : Management.Physical.S with type error = string) = struct - module Ops = Manipulation.Make(Storage) - module Branch = Management.Branch.Make(Storage) - module MergeOps = Management.Merge.Make(Storage)(Ops) + module Ops = Manipulation.Make (Storage) + module Branch = Management.Branch.Make (Storage) + module MergeOps = Management.Merge.Make (Storage) (Ops) type error = - | ParseError of string + | ParseError of string | BranchError of string - | MergeError of string + | MergeError of string let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | BranchError s -> List [Atom "branch-error"; Atom s] - | MergeError s -> List [Atom "merge-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | BranchError s -> List [ Atom "branch-error"; Atom s ] + | MergeError s -> List [ Atom "merge-error"; Atom s ] - let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = function - | Ast.PreferLeft -> Management.Merge.PreferLeft - | Ast.PreferRight -> Management.Merge.PreferRight + let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = + function + | Ast.PreferLeft -> Management.Merge.PreferLeft + | Ast.PreferRight -> Management.Merge.PreferRight | Ast.RevertToAncestor -> Management.Merge.RevertToAncestor - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (Management.Database.t * string, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (Management.Database.t * string, error) result = match stmt with - - | Ast.CreateBranch { name; hash } -> - let tip = match hash with - | Some h -> h - | None -> db.Management.Database.hash - in - (match Branch.create storage ~name ~tip with - | Error e -> Error (BranchError e) - | Ok () -> Ok (db, "Branch " ^ name ^ " created")) - - | Ast.Checkout branch_name -> - (match Branch.get_tip storage branch_name with - | Error e -> Error (BranchError e) - | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name)) - | Ok (Some tip) -> - (match Branch.checkout storage branch_name with - | Error e -> Error (BranchError e) - | Ok () -> - (match Ops.load_database storage tip with - | Error e -> Error (BranchError (Manipulation.string_of_error e)) - | Ok None -> Error (BranchError ("No database at hash: " ^ tip)) - | Ok (Some loaded_db) -> - Ok (loaded_db, "HEAD:" ^ branch_name)))) - - | Ast.GetHead -> - (match Branch.get_head storage with - | Error e -> Error (BranchError e) - | Ok None -> Ok (db, "HEAD is unset") - | Ok (Some name) -> Ok (db, "HEAD:" ^ name)) - - | Ast.GetBranchTip name -> - (match Branch.get_tip storage name with - | Error e -> Error (BranchError e) - | Ok None -> Error (BranchError ("Branch not found: " ^ name)) - | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash)) - - | Ast.UpdateBranchTip { name; hash } -> - (match Branch.update_tip storage ~name ~tip:hash with - | Error e -> Error (BranchError e) - | Ok () -> Ok (db, "Branch " ^ name ^ " updated")) - - | Ast.Merge { left; right; strategy } -> - (match Branch.get_tip storage left, Branch.get_tip storage right with - | Error e, _ | _, Error e -> Error (BranchError e) - | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left)) - | _, Ok None -> Error (BranchError ("Branch not found: " ^ right)) - | Ok (Some left_tip), Ok (Some right_tip) -> - let strat = convert_strategy strategy in - (match MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip with - | Error e -> Error (MergeError (Manipulation.string_of_error e)) - | Ok (Management.Merge.Failed conflicts) -> - let msgs = List.map (function - | Management.Merge.TupleConflict { relation; hash } -> - "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")" - | Management.Merge.SchemaConflict r -> "schema conflict in " ^ r - | Management.Merge.ConstraintConflict r -> "constraint conflict in " ^ r - ) conflicts in - Error (MergeError ("Merge failed: " ^ String.concat "; " msgs)) - | Ok (Management.Merge.Clean merged_db) -> - let _ = Branch.update_tip storage ~name:left - ~tip:merged_db.Management.Database.hash in - Ok (merged_db, - "Merged:" ^ right ^ "→" ^ left))) + | Ast.CreateBranch { name; hash } -> ( + let tip = + match hash with Some h -> h | None -> db.Management.Database.hash + in + match Branch.create storage ~name ~tip with + | Error e -> Error (BranchError e) + | Ok () -> Ok (db, "Branch " ^ name ^ " created")) + | Ast.Checkout branch_name -> ( + match Branch.get_tip storage branch_name with + | Error e -> Error (BranchError e) + | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name)) + | Ok (Some tip) -> ( + match Branch.checkout storage branch_name with + | Error e -> Error (BranchError e) + | Ok () -> ( + match Ops.load_database storage tip with + | Error e -> + Error (BranchError (Manipulation.string_of_error e)) + | Ok None -> Error (BranchError ("No database at hash: " ^ tip)) + | Ok (Some loaded_db) -> Ok (loaded_db, "HEAD:" ^ branch_name))) + ) + | Ast.GetHead -> ( + match Branch.get_head storage with + | Error e -> Error (BranchError e) + | Ok None -> Ok (db, "HEAD is unset") + | Ok (Some name) -> Ok (db, "HEAD:" ^ name)) + | Ast.GetBranchTip name -> ( + match Branch.get_tip storage name with + | Error e -> Error (BranchError e) + | Ok None -> Error (BranchError ("Branch not found: " ^ name)) + | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash)) + | Ast.UpdateBranchTip { name; hash } -> ( + match Branch.update_tip storage ~name ~tip:hash with + | Error e -> Error (BranchError e) + | Ok () -> Ok (db, "Branch " ^ name ^ " updated")) + | Ast.Merge { left; right; strategy } -> ( + match (Branch.get_tip storage left, Branch.get_tip storage right) with + | Error e, _ | _, Error e -> Error (BranchError e) + | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left)) + | _, Ok None -> Error (BranchError ("Branch not found: " ^ right)) + | Ok (Some left_tip), Ok (Some right_tip) -> ( + let strat = convert_strategy strategy in + match + MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip + with + | Error e -> Error (MergeError (Manipulation.string_of_error e)) + | Ok (Management.Merge.Failed conflicts) -> + let msgs = + List.map + (function + | Management.Merge.TupleConflict { relation; hash } -> + "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")" + | Management.Merge.SchemaConflict r -> + "schema conflict in " ^ r + | Management.Merge.ConstraintConflict r -> + "constraint conflict in " ^ r) + conflicts + in + Error (MergeError ("Merge failed: " ^ String.concat "; " msgs)) + | Ok (Management.Merge.Clean merged_db) -> + let _ = + Branch.update_tip storage ~name:left + ~tip:merged_db.Management.Database.hash + in + Ok (merged_db, "Merged:" ^ right ^ "→" ^ left))) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml index ef64924..79d8fc7 100644 --- a/lib/dcl/parser.ml +++ b/lib/dcl/parser.ml @@ -3,16 +3,12 @@ type error = ParseError of string let of_sexp sexp = (* ppx_sexp_conv encodes no-argument variants as bare atoms, so unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *) - let sexp = match sexp with - | Sexplib.Sexp.List [atom] -> atom - | other -> other + let sexp = + match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other in match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) -let of_string s = - of_sexp (Sexplib.Sexp.of_string s) - -let to_string stmt = - Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum +let of_string s = of_sexp (Sexplib.Sexp.of_string s) +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml index 112b6ed..c36e2a4 100644 --- a/lib/dcl/sublanguage.ml +++ b/lib/dcl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S with type error = string) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "dcl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S with type error = string) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/ddl/ast.ml b/lib/ddl/ast.ml index 7faee40..ee39edb 100644 --- a/lib/ddl/ast.ml +++ b/lib/ddl/ast.ml @@ -9,8 +9,8 @@ type cardinality_spec = type statement = | CreateDatabase 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 fbb2f62..d374ffe 100644 --- a/lib/ddl/executor.ml +++ b/lib/ddl/executor.ml @@ -1,68 +1,64 @@ module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) + module Ops = Manipulation.Make (Storage) type error = - | ParseError of string + | ParseError of string | ManipulationError of Manipulation.error - | RelationNotFound of string + | RelationNotFound of string let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] | ManipulationError e -> Manipulation.sexp_of_error e - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] let ( let* ) = Result.bind - let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r let get_rel db name = - Ops.get_relation db ~name - |> Option.to_result ~none:(RelationNotFound name) + Ops.get_relation db ~name |> Option.to_result ~none:(RelationNotFound name) - 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 + 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 | Ast.ConstrainedFinite -> Conventions.Cardinality.ConstrainedFinite - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (Management.Database.t * string, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (Management.Database.t * string, error) result = match stmt with | Ast.CreateDatabase name -> - let* db = Ops.create_database storage ~name |> wrap_manip in - Ok (db, "Database created: " ^ name) - + let* db = Ops.create_database storage ~name |> wrap_manip in + Ok (db, "Database created: " ^ name) | Ast.CreateRelation { name; schema = schema_pairs } -> - let schema = - List.fold_left (fun s (attr, dom) -> Schema.add attr dom s) Schema.empty schema_pairs - in - let* (db, _) = Ops.create_relation storage db ~name ~schema |> wrap_manip in - Ok (db, "Relation created: " ^ name) - + let schema = + List.fold_left + (fun s (attr, dom) -> Schema.add attr dom s) + Schema.empty schema_pairs + in + let* db, _ = + Ops.create_relation storage db ~name ~schema |> wrap_manip + in + Ok (db, "Relation created: " ^ name) | Ast.RetractRelation name -> - let* db = Ops.retract_relation storage db ~name |> wrap_manip in - Ok (db, "Relation retracted: " ^ name) - + let* db = Ops.retract_relation storage db ~name |> wrap_manip in + Ok (db, "Relation retracted: " ^ name) | Ast.ClearRelation name -> - let* rel = get_rel db name in - let* (db, _) = Ops.clear_relation storage db rel |> wrap_manip in - Ok (db, "Relation cleared: " ^ name) - + let* rel = get_rel db name in + let* db, _ = Ops.clear_relation storage db rel |> wrap_manip in + Ok (db, "Relation cleared: " ^ name) | Ast.RegisterDomain { name; cardinality } -> - let domain = Domain.make - ~name - ~generator:(fun _ -> Generator.Error "not enumerable via DDL") - ~membership_criteria:(fun _ -> true) - ~cardinality:(convert_cardinality cardinality) - ~compare:Stdlib.compare - in - let* db = Ops.register_domain storage db domain |> wrap_manip in - Ok (db, "Domain registered: " ^ name) + let domain = + Domain.make ~name + ~generator:(fun _ -> Generator.Error "not enumerable via DDL") + ~membership_criteria:(fun _ -> true) + ~cardinality:(convert_cardinality cardinality) + ~compare:Stdlib.compare + in + let* db = Ops.register_domain storage db domain |> wrap_manip in + Ok (db, "Domain registered: " ^ name) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml index 28f8b6c..5678b47 100644 --- a/lib/ddl/parser.ml +++ b/lib/ddl/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) -let to_string stmt = - Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/ddl/sublanguage.ml b/lib/ddl/sublanguage.ml index 26a012f..bf40a05 100644 --- a/lib/ddl/sublanguage.ml +++ b/lib/ddl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "ddl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dml/ast.ml b/lib/dml/ast.ml index 479437a..d8defe6 100644 --- a/lib/dml/ast.ml +++ b/lib/dml/ast.ml @@ -1,13 +1,12 @@ open Sexplib.Std -type attr_value = string * Drl.Ast.value -[@@deriving sexp] +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 } + | 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 } [@@deriving sexp] diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml index 7c08a24..08f1a26 100644 --- a/lib/dml/executor.ml +++ b/lib/dml/executor.ml @@ -1,117 +1,131 @@ module Make (Storage : Management.Physical.S) = struct - module Ops = Manipulation.Make(Storage) - module Alg = Algebra.Make(Storage) - module DrlExec = Drl.Executor.Make(Storage) + module Ops = Manipulation.Make (Storage) + module Alg = Algebra.Make (Storage) + module DrlExec = Drl.Executor.Make (Storage) type error = - | ParseError of string + | ParseError of string | ManipulationError of Manipulation.error - | RelationNotFound of string - | AlgebraError of Algebra.error + | RelationNotFound of string + | AlgebraError of Algebra.error let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | ManipulationError e -> Manipulation.sexp_of_error e - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] - | AlgebraError (Algebra.StorageError s) -> List [Atom "storage-error"; Atom s] - | AlgebraError (Algebra.GeneratorError s) -> List [Atom "generator-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | ManipulationError e -> Manipulation.sexp_of_error e + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + | AlgebraError (Algebra.StorageError s) -> + List [ Atom "storage-error"; Atom s ] + | AlgebraError (Algebra.GeneratorError s) -> + List [ Atom "generator-error"; Atom s ] let ( let* ) = Result.bind - let wrap_manip r = Result.map_error (fun e -> ManipulationError e) r - let wrap_alg e = AlgebraError e let get_rel db name = match Ops.get_relation db ~name with | Some r -> Ok r - | None -> Error (RelationNotFound name) + | None -> Error (RelationNotFound name) - let retarget target (t : Tuple.materialized) = { t with Tuple.relation = target } + let retarget target (t : Tuple.materialized) = + { t with Tuple.relation = target } (** Build a materialized tuple from a list of (attr_name, ast_value) pairs *) - let build_tuple ~relation (attributes : Ast.attr_value list) : Tuple.materialized = + 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.empty - attributes + Tuple.AttributeMap.empty attributes in { Tuple.relation; attributes = attr_map } let eval_query storage db query = match DrlExec.execute storage db query with | Ok rel -> Ok rel - | Error (DrlExec.ParseError s) -> Error (ParseError s) + | Error (DrlExec.ParseError s) -> Error (ParseError s) | Error (DrlExec.RelationNotFound s) -> Error (RelationNotFound s) - | Error (DrlExec.AlgebraError e) -> Error (AlgebraError e) + | Error (DrlExec.AlgebraError e) -> Error (AlgebraError e) let materialize_tuples storage rel = Result.map_error wrap_alg (Alg.materialize storage rel) - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (Management.Database.t, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (Management.Database.t, error) result = match stmt with | Ast.InsertTuple { relation; attributes } -> - let* rel = get_rel db relation in - let tuple = build_tuple ~relation attributes in - let* (db, _, _) = Ops.create_tuple storage db rel tuple |> wrap_manip in - Ok db - + let* rel = get_rel db relation in + let tuple = build_tuple ~relation attributes in + let* db, _, _ = Ops.create_tuple storage db rel tuple |> wrap_manip in + Ok db | Ast.InsertTuples { relation; tuples } -> - let* rel = get_rel db relation in - let tuple_list = List.map (build_tuple ~relation) tuples in - let* (db, _, _) = Ops.create_tuples storage db rel tuple_list |> wrap_manip in - Ok db - + let* rel = get_rel db relation in + let tuple_list = List.map (build_tuple ~relation) tuples in + let* db, _, _ = + Ops.create_tuples storage db rel tuple_list |> wrap_manip + in + Ok db | Ast.DeleteTuple { relation; attributes } -> - let* rel = get_rel db relation in - let tuple = build_tuple ~relation attributes in - let tuple_hash = Hashing.hash_tuple tuple in - let* (db, _) = Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip in - Ok db - + let* rel = get_rel db relation in + let tuple = build_tuple ~relation attributes in + let tuple_hash = Hashing.hash_tuple tuple in + let* db, _ = + Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip + in + Ok db | Ast.Assign { target; body } -> - let* rel = get_rel db target in - let* result_rel = eval_query storage db body in - let* tuples = materialize_tuples storage result_rel in - let* (db, rel) = Ops.clear_relation storage db rel |> wrap_manip in - let* (db, _, _) = Ops.create_tuples storage db rel (List.map (retarget target) tuples) |> wrap_manip in - Ok db - + let* rel = get_rel db target in + let* result_rel = eval_query storage db body in + let* tuples = materialize_tuples storage result_rel in + let* db, rel = Ops.clear_relation storage db rel |> wrap_manip in + let* db, _, _ = + Ops.create_tuples storage db rel (List.map (retarget target) tuples) + |> wrap_manip + in + Ok db | Ast.InsertFrom { target; source } -> - let* rel = get_rel db target in - let* result_rel = eval_query storage db source in - let* tuples = materialize_tuples storage result_rel in - let* (db, _, _) = Ops.create_tuples storage db rel (List.map (retarget target) tuples) |> wrap_manip in - Ok db - + let* rel = get_rel db target in + let* result_rel = eval_query storage db source in + let* tuples = materialize_tuples storage result_rel in + let* db, _, _ = + Ops.create_tuples storage db rel (List.map (retarget target) tuples) + |> wrap_manip + in + Ok db | Ast.DeleteWhere { target; predicate } -> - let* rel = get_rel db target in - let* pred_rel = eval_query storage db predicate in - let common = List.filter_map - (fun (n, _) -> if List.exists (fun (m, _) -> m = n) pred_rel.Relation.schema - then Some n else None) - rel.Relation.schema in - let* joined = Alg.equijoin storage common rel pred_rel |> Result.map_error wrap_alg in - let* to_delete = Alg.project storage (List.map fst rel.Relation.schema) joined - |> Result.map_error wrap_alg in - let* tuples = materialize_tuples storage to_delete in - List.fold_left (fun acc t -> - let* db = acc in let* rel = get_rel db target in - let tuple_hash = Hashing.hash_tuple (retarget target t) in - let* (db, _) = Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip in - Ok db) - (Ok db) tuples + let* pred_rel = eval_query storage db predicate in + let common = + List.filter_map + (fun (n, _) -> + if List.exists (fun (m, _) -> m = n) pred_rel.Relation.schema then + Some n + else None) + rel.Relation.schema + in + let* joined = + Alg.equijoin storage common rel pred_rel |> Result.map_error wrap_alg + in + let* to_delete = + Alg.project storage (List.map fst rel.Relation.schema) joined + |> Result.map_error wrap_alg + in + let* tuples = materialize_tuples storage to_delete in + List.fold_left + (fun acc t -> + let* db = acc in + let* rel = get_rel db target in + let tuple_hash = Hashing.hash_tuple (retarget target t) in + let* db, _ = + Ops.retract_tuple storage db rel ~tuple_hash |> wrap_manip + in + Ok db) + (Ok db) tuples end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dml/parser.ml b/lib/dml/parser.ml index 28f8b6c..5678b47 100644 --- a/lib/dml/parser.ml +++ b/lib/dml/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) -let to_string stmt = - Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/dml/sublanguage.ml b/lib/dml/sublanguage.ml index 29f951e..29b1b77 100644 --- a/lib/dml/sublanguage.ml +++ b/lib/dml/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "dml" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl/ast.ml b/lib/drl/ast.ml index 2beb010..6b191bb 100644 --- a/lib/drl/ast.ml +++ b/lib/drl/ast.ml @@ -1,32 +1,28 @@ open Sexplib.Std (** Literal values for Const nodes *) -type value = - | Int of int - | Float of float - | Str of string - | Bool of bool +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 - | Int n -> Obj.repr n + | Int n -> Obj.repr n | Float f -> Obj.repr f - | Str s -> Obj.repr s - | Bool b -> Obj.repr b + | Str s -> Obj.repr s + | Bool b -> Obj.repr b -type direction = Asc | Desc -[@@deriving sexp] +type direction = Asc | Desc [@@deriving sexp] 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 *) - | Cartesian of query * query (** × Cartesian product *) - | Project of string list * query (** π restrict columns *) - | Rename of (string * string) list * query (** ρ rename (old,new) pairs *) - | Union of query * query (** ∪ — compatible schemas assumed *) - | Diff of query * query (** − *) - | Take of int * 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 *) + | Cartesian of query * query (** × Cartesian product *) + | Project of string list * query (** π restrict columns *) + | Rename of (string * string) list * query (** ρ rename (old,new) pairs *) + | Union of query * query (** ∪ — compatible schemas assumed *) + | Diff of query * query (** − *) + | Take of int * query (** τ *) [@@deriving sexp] diff --git a/lib/drl/executor.ml b/lib/drl/executor.ml index 322fada..f1732eb 100644 --- a/lib/drl/executor.ml +++ b/lib/drl/executor.ml @@ -1,74 +1,74 @@ -module Make(Storage : Management.Physical.S) = struct - module Alg = Algebra.Make(Storage) - module Ops = Manipulation.Make(Storage) +module Make (Storage : Management.Physical.S) = struct + module Alg = Algebra.Make (Storage) + module Ops = Manipulation.Make (Storage) type error = - | ParseError of string + | ParseError of string | RelationNotFound of string - | AlgebraError of Algebra.error + | AlgebraError of Algebra.error let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | RelationNotFound s -> List [Atom "relation-not-found"; Atom s] - | AlgebraError (Algebra.StorageError s) -> List [Atom "storage-error"; Atom s] - | AlgebraError (Algebra.GeneratorError s) -> List [Atom "generator-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ] + | AlgebraError (Algebra.StorageError s) -> + List [ Atom "storage-error"; Atom s ] + | AlgebraError (Algebra.GeneratorError s) -> + List [ Atom "generator-error"; Atom s ] let wrap = Result.map_error (fun e -> AlgebraError e) - let ast_value_to_abstract = Ast.value_to_abstract - let rec execute - (storage : Storage.t) - (db : Management.Database.t) - (q : Ast.query) - : (Relation.t, error) Result.t = + let rec execute (storage : Storage.t) (db : Management.Database.t) + (q : Ast.query) : (Relation.t, error) Result.t = let ( >>= ) = Result.bind in match q with - | Ast.Base name -> - (match Ops.get_relation db ~name with - | None -> Error (RelationNotFound name) - | Some rel -> Ok rel) + | Ast.Base name -> ( + match Ops.get_relation db ~name with + | None -> Error (RelationNotFound name) + | Some rel -> Ok rel) | Ast.Const pairs -> - Ok (Alg.const_relation - (List.map (fun (k, v) -> (k, ast_value_to_abstract v)) pairs)) + Ok + (Alg.const_relation + (List.map (fun (k, v) -> (k, ast_value_to_abstract v)) pairs)) | Ast.Select (filter_q, source_q) -> - execute storage db filter_q >>= fun filter -> - execute storage db source_q >>= fun source -> - (* semijoin = project(source attrs, equijoin on common attrs) *) - let common = List.filter_map (fun (n, _) -> - if List.exists (fun (m, _) -> m = n) filter.Relation.schema - then Some n else None) source.Relation.schema in - let source_attrs = List.map fst source.Relation.schema in - wrap (Alg.equijoin storage common source filter) >>= fun joined -> - wrap (Alg.project storage source_attrs joined) + execute storage db filter_q >>= fun filter -> + execute storage db source_q >>= fun source -> + (* semijoin = project(source attrs, equijoin on common attrs) *) + let common = + List.filter_map + (fun (n, _) -> + if List.exists (fun (m, _) -> m = n) filter.Relation.schema then + Some n + else None) + source.Relation.schema + in + let source_attrs = List.map fst source.Relation.schema in + wrap (Alg.equijoin storage common source filter) >>= fun joined -> + wrap (Alg.project storage source_attrs joined) | Ast.Join (attrs, q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.equijoin storage attrs r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> + wrap (Alg.equijoin storage attrs r1 r2) | Ast.Project (attrs, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.project storage attrs rel) + execute storage db q >>= fun rel -> wrap (Alg.project storage attrs rel) | Ast.Rename (renames, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.rename storage renames rel) + execute storage db q >>= fun rel -> + wrap (Alg.rename storage renames rel) | Ast.Cartesian (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - (* Cartesian product = join on no attrs *) - wrap (Alg.equijoin storage [] r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> + (* Cartesian product = join on no attrs *) + wrap (Alg.equijoin storage [] r1 r2) | Ast.Union (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.union storage r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> wrap (Alg.union storage r1 r2) | Ast.Diff (q1, q2) -> - execute storage db q1 >>= fun r1 -> - execute storage db q2 >>= fun r2 -> - wrap (Alg.diff storage r1 r2) + execute storage db q1 >>= fun r1 -> + execute storage db q2 >>= fun r2 -> wrap (Alg.diff storage r1 r2) | Ast.Take (n, q) -> - execute storage db q >>= fun rel -> - wrap (Alg.take storage n rel) + execute storage db q >>= fun rel -> wrap (Alg.take storage n rel) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl/gate.ml b/lib/drl/gate.ml index 222e935..a314bce 100644 --- a/lib/drl/gate.ml +++ b/lib/drl/gate.ml @@ -1,8 +1,8 @@ (** Finiteness gate for DRL queries. - Converts Sakura types to Coq-extracted types and calls the - verified [predicted_finite] function. Rejects queries whose - result cannot be statically proven finite. *) + Converts Sakura types to Coq-extracted types and calls the verified + [predicted_finite] function. Rejects queries whose result cannot be + statically proven finite. *) (* -- string -> char list impedance --------------------------------- *) @@ -12,71 +12,68 @@ let string_to_chars (s : string) : char list = (* -- Sakura AST -> extracted AST ----------------------------------- *) let rec query_of_ast : Ast.query -> Drl_verified.query = function - | Ast.Base name -> - Drl_verified.Base (string_to_chars name) + | Ast.Base name -> Drl_verified.Base (string_to_chars name) | Ast.Const pairs -> - Drl_verified.Const - (List.map - (fun (k, v) -> - (string_to_chars k, value_of_ast_value v)) - pairs) + Drl_verified.Const + (List.map + (fun (k, v) -> (string_to_chars k, value_of_ast_value v)) + pairs) | Ast.Select (filter, source) -> - Drl_verified.Select (query_of_ast filter, query_of_ast source) + Drl_verified.Select (query_of_ast filter, query_of_ast source) | Ast.Join (attrs, q1, q2) -> - Drl_verified.Join - (List.map string_to_chars attrs, query_of_ast q1, query_of_ast q2) + Drl_verified.Join + (List.map string_to_chars attrs, query_of_ast q1, query_of_ast q2) | Ast.Cartesian (q1, q2) -> - Drl_verified.Cartesian (query_of_ast q1, query_of_ast q2) + Drl_verified.Cartesian (query_of_ast q1, query_of_ast q2) | Ast.Project (attrs, q) -> - Drl_verified.Project (List.map string_to_chars attrs, query_of_ast q) + Drl_verified.Project (List.map string_to_chars attrs, query_of_ast q) | Ast.Rename (renames, q) -> - Drl_verified.Rename - (List.map - (fun (o, n) -> (string_to_chars o, string_to_chars n)) - renames, - query_of_ast q) - | Ast.Union (q1, q2) -> - Drl_verified.Union (query_of_ast q1, query_of_ast q2) - | Ast.Diff (q1, q2) -> - Drl_verified.Diff (query_of_ast q1, query_of_ast q2) - | Ast.Take (n, q) -> - Drl_verified.Take (n, query_of_ast q) + Drl_verified.Rename + ( List.map (fun (o, n) -> (string_to_chars o, string_to_chars n)) renames, + query_of_ast q ) + | Ast.Union (q1, q2) -> Drl_verified.Union (query_of_ast q1, query_of_ast q2) + | Ast.Diff (q1, q2) -> Drl_verified.Diff (query_of_ast q1, query_of_ast q2) + | Ast.Take (n, q) -> Drl_verified.Take (n, query_of_ast q) and value_of_ast_value : Ast.value -> Drl_verified.literal = function - | Ast.Int n -> Drl_verified.LitInt n + | Ast.Int n -> Drl_verified.LitInt n (* The Coq model has no float literal. This truncation is harmless: the finiteness gate inspects only relation names and query structure, never literal values. *) | Ast.Float f -> Drl_verified.LitInt (int_of_float f) - | Ast.Str s -> Drl_verified.LitStr (string_to_chars s) - | Ast.Bool b -> Drl_verified.LitBool b + | Ast.Str s -> Drl_verified.LitStr (string_to_chars s) + | Ast.Bool b -> Drl_verified.LitBool b (* -- database snapshot --------------------------------------------- *) let is_finite (c : Conventions.Cardinality.t) : bool = match c with - | Conventions.Cardinality.Finite _ | Conventions.Cardinality.ConstrainedFinite -> true - | Conventions.Cardinality.AlephZero | Conventions.Cardinality.Continuum -> false + | Conventions.Cardinality.Finite _ | Conventions.Cardinality.ConstrainedFinite + -> + true + | Conventions.Cardinality.AlephZero | Conventions.Cardinality.Continuum -> + false let database_snapshot (db : Management.Database.t) : Drl_verified.database = Management.Database.RelationMap.fold (fun name (rel : Relation.t) acc -> - let entry : Drl_verified.relation = - { rel_name = string_to_chars name; - rel_finite = is_finite rel.cardinality } - in - (string_to_chars name, entry) :: acc) - db.relations - [] + let entry : Drl_verified.relation = + { + rel_name = string_to_chars name; + rel_finite = is_finite rel.cardinality; + } + in + (string_to_chars name, entry) :: acc) + db.relations [] (* -- public interface ---------------------------------------------- *) -let admit (db : Management.Database.t) (ast : Ast.query) : (unit, string) result = +let admit (db : Management.Database.t) (ast : Ast.query) : (unit, string) result + = let vdb = database_snapshot db in let vq = query_of_ast ast in match Drl_verified.predicted_finite vdb vq with | Some true -> Ok () | Some false -> - Error "query produces potentially infinite result; use Take to bound it" - | None -> - Error "referenced relation not found in finiteness check" + Error "query produces potentially infinite result; use Take to bound it" + | None -> Error "referenced relation not found in finiteness check" diff --git a/lib/drl/parser.ml b/lib/drl/parser.ml index 36ce15a..76d4b4e 100644 --- a/lib/drl/parser.ml +++ b/lib/drl/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.query_of_sexp sexp with - | q -> Ok q + | q -> Ok q | exception exn -> Error (ParseError (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.query_of_sexp with - | q -> Ok q + | q -> Ok q | exception exn -> Error (ParseError (Printexc.to_string exn)) -let to_string q = - Ast.sexp_of_query q |> Sexplib.Sexp.to_string_hum +let to_string q = Ast.sexp_of_query q |> Sexplib.Sexp.to_string_hum diff --git a/lib/drl/sublanguage.ml b/lib/drl/sublanguage.ml index f57af95..ce69b56 100644 --- a/lib/drl/sublanguage.ml +++ b/lib/drl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.query - type error = Exec.error + type ast = Ast.query + type error = Exec.error let name = "drl" @@ -15,12 +15,12 @@ module Make (Storage : Management.Physical.S) = struct let execute storage db ast = match Gate.admit db ast with | Error msg -> Error (Exec.ParseError msg) - | Ok () -> - match Exec.execute storage db ast with - | Ok rel -> Ok (Sublanguage.Query rel) - | Error e -> Error e + | Ok () -> ( + match Exec.execute storage db ast with + | Ok rel -> Ok (Sublanguage.Query rel) + | Error e -> Error e) let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/drl_verified/drl_verified.ml b/lib/drl_verified/drl_verified.ml index b5aeaa7..868af2a 100644 --- a/lib/drl_verified/drl_verified.ml +++ b/lib/drl_verified/drl_verified.ml @@ -1,76 +1,67 @@ - (** val eqb : char list -> char list -> bool **) let rec eqb s1 s2 = match s1 with - | [] -> (match s2 with - | [] -> true - | _::_ -> false) - | c1::s1' -> - (match s2 with - | [] -> false - | c2::s2' -> if (=) c1 c2 then eqb s1' s2' else false) + | [] -> ( match s2 with [] -> true | _ :: _ -> false) + | c1 :: s1' -> ( + match s2 with + | [] -> false + | c2 :: s2' -> if c1 = c2 then eqb s1' s2' else false) type attr_name = char list - type relation = { rel_name : char list; rel_finite : bool } - type database = (char list * relation) list (** val db_lookup : char list -> database -> relation option **) let rec db_lookup name = function -| [] -> None -| p :: rest -> - let (n, r) = p in if eqb name n then Some r else db_lookup name rest + | [] -> None + | p :: rest -> + let n, r = p in + if eqb name n then Some r else db_lookup name rest -type literal = -| LitInt of int -| LitStr of char list -| LitBool of bool +type literal = LitInt of int | LitStr of char list | LitBool of bool type query = -| Base of char list -| Const of (attr_name * literal) list -| Select of query * query -| Join of attr_name list * query * query -| Cartesian of query * query -| Project of attr_name list * query -| Rename of (attr_name * attr_name) list * query -| Union of query * query -| Diff of query * query -| Take of int * query + | Base of char list + | Const of (attr_name * literal) list + | Select of query * query + | Join of attr_name list * query * query + | Cartesian of query * query + | Project of attr_name list * query + | Rename of (attr_name * attr_name) list * query + | Union of query * query + | Diff of query * query + | Take of int * query (** val predicted_finite : database -> query -> bool option **) let rec predicted_finite db = function -| Base name -> - (match db_lookup name db with - | Some r -> Some r.rel_finite - | None -> None) -| Select (_, source) -> predicted_finite db source -| Join (_, q1, q2) -> - (match predicted_finite db q1 with - | Some f1 -> - (match predicted_finite db q2 with - | Some f2 -> Some ((&&) f1 f2) + | Base name -> ( + match db_lookup name db with Some r -> Some r.rel_finite | None -> None) + | Select (_, source) -> predicted_finite db source + | Join (_, q1, q2) -> ( + match predicted_finite db q1 with + | Some f1 -> ( + match predicted_finite db q2 with + | Some f2 -> Some (f1 && f2) + | None -> None) | None -> None) - | None -> None) -| Cartesian (q1, q2) -> - (match predicted_finite db q1 with - | Some f1 -> - (match predicted_finite db q2 with - | Some f2 -> Some ((&&) f1 f2) + | Cartesian (q1, q2) -> ( + match predicted_finite db q1 with + | Some f1 -> ( + match predicted_finite db q2 with + | Some f2 -> Some (f1 && f2) + | None -> None) | None -> None) - | None -> None) -| Project (_, q0) -> predicted_finite db q0 -| Rename (_, q0) -> predicted_finite db q0 -| Union (q1, q2) -> - (match predicted_finite db q1 with - | Some f1 -> - (match predicted_finite db q2 with - | Some f2 -> Some ((&&) f1 f2) + | Project (_, q0) -> predicted_finite db q0 + | Rename (_, q0) -> predicted_finite db q0 + | Union (q1, q2) -> ( + match predicted_finite db q1 with + | Some f1 -> ( + match predicted_finite db q2 with + | Some f2 -> Some (f1 && f2) + | None -> None) | None -> None) - | None -> None) -| Diff (q1, _) -> predicted_finite db q1 -| _ -> Some true + | Diff (q1, _) -> predicted_finite db q1 + | _ -> Some true diff --git a/lib/drl_verified/drl_verified.mli b/lib/drl_verified/drl_verified.mli index 31acc7a..dac930e 100644 --- a/lib/drl_verified/drl_verified.mli +++ b/lib/drl_verified/drl_verified.mli @@ -1,29 +1,23 @@ - val eqb : char list -> char list -> bool type attr_name = char list - type relation = { rel_name : char list; rel_finite : bool } - type database = (char list * relation) list val db_lookup : char list -> database -> relation option -type literal = -| LitInt of int -| LitStr of char list -| LitBool of bool +type literal = LitInt of int | LitStr of char list | LitBool of bool type query = -| Base of char list -| Const of (attr_name * literal) list -| Select of query * query -| Join of attr_name list * query * query -| Cartesian of query * query -| Project of attr_name list * query -| Rename of (attr_name * attr_name) list * query -| Union of query * query -| Diff of query * query -| Take of int * query + | Base of char list + | Const of (attr_name * literal) list + | Select of query * query + | Join of attr_name list * query * query + | Cartesian of query * query + | Project of attr_name list * query + | Rename of (attr_name * attr_name) list * query + | Union of query * query + | Diff of query * query + | Take of int * query val predicted_finite : database -> query -> bool option @@ -1,4 +1,5 @@ (include_subdirs qualified) + (library (name relational_engine) (libraries diff --git a/lib/envelope.ml b/lib/envelope.ml index d8404d9..bed8bc0 100644 --- a/lib/envelope.ml +++ b/lib/envelope.ml @@ -1,18 +1,17 @@ (** Envelope parser for tagged S-expressions. - Parses commands of the form (tag payload...) where the tag selects - which sublanguage handles the payload. The tag set is open — future - sublanguages (tcl, ppl, acl) just add new tags. *) + Parses commands of the form (tag payload...) where the tag selects which + sublanguage handles the payload. The tag set is open — future sublanguages + (tcl, ppl, acl) just add new tags. *) type tagged = { tag : string; payload : Sexplib.Sexp.t } let parse (input : string) : (tagged, string) Result.t = match Sexplib.Sexp.of_string input with | Sexplib.Sexp.List (Sexplib.Sexp.Atom tag :: rest) -> - let payload = match rest with - | [single] -> single - | many -> Sexplib.Sexp.List many - in - Ok { tag; payload } + let payload = + match rest with [ single ] -> single | many -> Sexplib.Sexp.List many + in + Ok { tag; payload } | _ -> Error "expected (tag payload...)" | exception exn -> Error (Printexc.to_string exn) diff --git a/lib/generator.ml b/lib/generator.ml index 44f1579..5939ec9 100644 --- a/lib/generator.ml +++ b/lib/generator.ml @@ -2,5 +2,5 @@ type result = | Done | Value of Tuple.t * (int option -> result) | Error of string - - and t = int option -> result
\ No newline at end of file + +and t = int option -> result diff --git a/lib/hashing.ml b/lib/hashing.ml index 4709ded..9475e46 100644 --- a/lib/hashing.ml +++ b/lib/hashing.ml @@ -1,8 +1,8 @@ (** Hash computation for tuples and relations. This module provides content-addressable hashing for the relational engine. - All hashes are deterministic - the same content always produces the same hash. - This enables: + All hashes are deterministic - the same content always produces the same + hash. This enables: - Deduplication of tuples - Merkle tree construction for relations and databases - Time-travel queries (load any historical state by hash) *) @@ -16,38 +16,41 @@ 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 -(** Compute hash for a tuple. - The hash is computed from: +(** Compute hash for a tuple. The hash is computed from: - The relation name - - All attribute names and their marshalled values (sorted by name for determinism) *) + - All attribute names and their marshalled values (sorted by name for + determinism) *) let hash_tuple (tuple : Tuple.materialized) : Conventions.Hash.t = let sorted_attrs = Tuple.AttributeMap.bindings tuple.attributes |> List.sort (fun (a, _) (b, _) -> String.compare a b) in let content = - 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_hex = bytes_to_hex value_bytes in - acc ^ name ^ ":" ^ value_hex ^ ";" - ) (tuple.relation ^ "|") sorted_attrs + 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_hex = bytes_to_hex value_bytes in + acc ^ name ^ ":" ^ value_hex ^ ";") + (tuple.relation ^ "|") sorted_attrs in Conventions.Hash.hash_text content -(** Compute hash for a relation. - The hash is computed from: +(** Compute hash for a relation. The hash is computed from: - The relation name - The schema (attribute names and types) - The merkle tree root hash (representing all tuples) *) let hash_relation ~name ~(schema : Schema.t) ~tree : Conventions.Hash.t = let schema_str = Schema.to_string schema in - let tree_hash = match Merkle.root_hash tree with - | Some h -> h - | None -> "empty" + let tree_hash = + match Merkle.root_hash tree with Some h -> h | None -> "empty" in Conventions.Hash.hash_text (name ^ "|" ^ schema_str ^ "|" ^ tree_hash) diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml index 95e0271..30b0fa7 100644 --- a/lib/icl/ast.ml +++ b/lib/icl/ast.ml @@ -6,18 +6,18 @@ type binding_expr = [@@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; + constraint_name : string; + relation_name : string; + body : constraint_body; } [@@deriving sexp] diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml index 28f8b6c..5678b47 100644 --- a/lib/icl/parser.ml +++ b/lib/icl/parser.ml @@ -2,13 +2,12 @@ type error = ParseError of string let of_sexp sexp = match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) let of_string s = match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) -let to_string stmt = - Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/icl/sublanguage.ml b/lib/icl/sublanguage.ml index 4e74082..56f3e4b 100644 --- a/lib/icl/sublanguage.ml +++ b/lib/icl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "icl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/interop.ml b/lib/interop.ml index ea25e0c..8cbc05c 100644 --- a/lib/interop.ml +++ b/lib/interop.ml @@ -2,7 +2,8 @@ open Ctypes module Sha256 = struct type t = string - let compute_hash content: t = + + let compute_hash content : t = let size_with_null_terminator = C.Types.hash_size + 1 in let buf = Ctypes.allocate_n char ~count:size_with_null_terminator in let () = C.Functions.compute_hash buf (Bytes.to_string content) in diff --git a/lib/management/branch.ml b/lib/management/branch.ml index 70dfd85..ea15311 100644 --- a/lib/management/branch.ml +++ b/lib/management/branch.ml @@ -4,13 +4,8 @@ - "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 let branch_key name = "branch:" ^ name @@ -18,7 +13,6 @@ let head_key = "head" let names_key = "branch_names" module Make (Storage : Physical.S with type error = string) = struct - let load_names storage = match Storage.load_raw storage names_key with | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list) @@ -31,13 +25,12 @@ module Make (Storage : Physical.S with type error = string) = struct let create storage ~name ~tip = 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 - | Ok () -> - let names = load_names storage in - if not (List.mem name names) then - store_names storage (name :: names); - Ok ()) + match Storage.store_raw storage (branch_key name) bytes with + | Error e -> Error e + | Ok () -> + let names = load_names storage in + if not (List.mem name names) then store_names storage (name :: names); + Ok () let checkout storage branch_name = let bytes = Bytes.of_string branch_name in @@ -52,27 +45,30 @@ module Make (Storage : Physical.S with type error = string) = struct let get_tip storage name = match Storage.load_raw storage (branch_key name) with | Ok (Some bytes) -> - let record : t = Marshal.from_bytes bytes 0 in - Ok (Some record.tip) + let record : t = Marshal.from_bytes bytes 0 in + Ok (Some record.tip) | Ok None -> Ok None | Error e -> Error e let update_tip storage ~name ~tip = match Storage.load_raw storage (branch_key name) with | Ok (Some _) -> - let record = { name; tip } in - let bytes = Marshal.to_bytes record [] in - Storage.store_raw storage (branch_key name) bytes + let record = { name; tip } in + let bytes = Marshal.to_bytes record [] in + Storage.store_raw storage (branch_key name) bytes | Ok None -> Error ("Branch not found: " ^ name) | Error e -> Error e let list storage = 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 - ) names in + let branches = + List.filter_map + (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 = @@ -83,23 +79,22 @@ module Make (Storage : Physical.S with type error = string) = struct let rec generator position = match position with | None -> Generator.Error "random access not supported for sakura:branch" - | Some pos -> - (match list storage with - | Error _ -> Generator.Done - | Ok branches -> - if pos >= List.length branches then Generator.Done - else - let (name, tip) = List.nth branches pos in - let short = String.sub tip 0 (min 8 (String.length tip)) in - let attributes = - Tuple.AttributeMap.of_list - [ ("name", mk name) - ; ("hash", mk short) - ] - in - Generator.Value - ( Tuple.make_materialized ~relation:Prelude.Catalog.branch_rel_name ~attributes - , generator )) + | Some pos -> ( + match list storage with + | Error _ -> Generator.Done + | Ok branches -> + if pos >= List.length branches then Generator.Done + else + let name, tip = List.nth branches pos in + let short = String.sub tip 0 (min 8 (String.length tip)) in + let attributes = + Tuple.AttributeMap.of_list + [ ("name", mk name); ("hash", mk short) ] + in + Generator.Value + ( Tuple.make_materialized + ~relation:Prelude.Catalog.branch_rel_name ~attributes, + generator )) in Relation.make ~hash:None ~name:Prelude.Catalog.branch_rel_name ~schema ~tree:None ~constraints:None @@ -115,16 +110,17 @@ module Make (Storage : Physical.S with type error = string) = struct let generator position = match position with | None -> Generator.Error "random access not supported for sakura:head" - | Some 0 -> - (match get_head storage with - | Ok None | Error _ -> Generator.Done - | Ok (Some branch_name) -> - let attributes = - Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:Prelude.Catalog.head_rel_name ~attributes - , fun _ -> Generator.Done )) + | Some 0 -> ( + match get_head storage with + | Ok None | Error _ -> Generator.Done + | Ok (Some branch_name) -> + let attributes = + Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ] + in + Generator.Value + ( Tuple.make_materialized + ~relation:Prelude.Catalog.head_rel_name ~attributes, + fun _ -> Generator.Done )) | Some _ -> Generator.Done in Relation.make ~hash:None ~name:Prelude.Catalog.head_rel_name ~schema @@ -134,5 +130,4 @@ module Make (Storage : Physical.S with type error = string) = struct ~membership_criteria:(fun _ -> true) ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name) ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) - end diff --git a/lib/management/merge.ml b/lib/management/merge.ml index e50d0e6..d30545a 100644 --- a/lib/management/merge.ml +++ b/lib/management/merge.ml @@ -1,40 +1,37 @@ -(** 3-way merge of two branch tips using their Lowest Common Ancestor. - Walks the history chain to find it, diffs both sides against it, - applies merge rules, validates constraints, and persists the result. *) +(** 3-way merge of two branch tips using their Lowest Common Ancestor. Walks the + history chain to find it, diffs both sides against it, applies merge rules, + validates constraints, and persists the result. *) type conflict = - | TupleConflict of { relation: string; hash: Conventions.Hash.t } - | SchemaConflict of string + | TupleConflict of { relation : string; hash : Conventions.Hash.t } + | SchemaConflict of string | ConstraintConflict of string type strategy = PreferLeft | PreferRight | RevertToAncestor - -type merge_result = - | Clean of Database.t - | Failed of conflict list +type merge_result = Clean of Database.t | Failed of conflict list (** Module type for the subset of Manipulation.Make we need. *) module type MANIPULATION = sig type storage type error - val of_string_error : string -> error - val load_database : storage -> Conventions.Hash.t -> (Database.t option, error) result + + val of_string_error : string -> error + + val load_database : + storage -> Conventions.Hash.t -> (Database.t option, error) result + val store_database : storage -> Database.t -> (unit, error) result end -module StringSet = Set.Make(String) +module StringSet = Set.Make (String) (** Walk history to find LCA. First hash in right's ancestry that also appears in left's ancestry set. *) let find_lca left_db right_db = let left_ancestors = - StringSet.of_list (left_db.Database.hash - :: left_db.Database.history) - in - let right_chain = - right_db.Database.hash - :: right_db.Database.history + StringSet.of_list (left_db.Database.hash :: left_db.Database.history) in + let right_chain = right_db.Database.hash :: right_db.Database.history in List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain (** Apply a single relation diff to a database, using strategy on conflicts. *) @@ -42,104 +39,140 @@ let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff) ~(right_diff : Diff.relation_diff option) : Database.t * conflict list = match left_diff with | Diff.RelationAdded rel -> - (* Only left added it; right_diff must be None or same *) - (Database.add_relation db ~relation:rel, []) - - | Diff.RelationRemoved name -> - (Database.remove_relation db ~name, []) - - | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } -> - let conflicts = ref [] in - (* Determine the merged relation's Merkle tree *) - let base_rel_opt = Database.get_relation db name in - (match base_rel_opt with - | None -> (db, []) - | Some base_rel -> - let base_tree = Option.value base_rel.Relation.tree ~default:Merkle.empty in - (* Handle schema conflict *) - let (resolved_rel, schema_conflict) = - if schema_changed then - match right_diff with - | Some (Diff.RelationModified { schema_changed = true; _ }) -> - (* Both changed schema — apply strategy *) - let winner = match strategy with - | PreferLeft -> Database.get_relation left_db name - | PreferRight -> Database.get_relation right_db name - | RevertToAncestor -> Some base_rel - in - (Option.value winner ~default:base_rel, [SchemaConflict name]) - | _ -> - (* Only left changed schema — take left's relation *) - let left_rel = Option.value - (Database.get_relation left_db name) ~default:base_rel in - (left_rel, []) - else (base_rel, []) - in - conflicts := schema_conflict @ !conflicts; - (* Apply tuple adds/removes from left *) - let merged_tree = - List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples - in - let merged_tree = - List.fold_left (fun t h -> Merkle.delete h t) merged_tree removed_tuples - in - (* Apply tuple adds/removes from right if disjoint *) - let merged_tree = match right_diff with - | Some (Diff.RelationModified + (* Only left added it; right_diff must be None or same *) + (Database.add_relation db ~relation:rel, []) + | Diff.RelationRemoved name -> (Database.remove_relation db ~name, []) + | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } + -> ( + let conflicts = ref [] in + (* Determine the merged relation's Merkle tree *) + let base_rel_opt = Database.get_relation db name in + match base_rel_opt with + | None -> (db, []) + | Some base_rel -> + let base_tree = + Option.value base_rel.Relation.tree ~default:Merkle.empty + in + (* Handle schema conflict *) + let resolved_rel, schema_conflict = + if schema_changed then + match right_diff with + | Some (Diff.RelationModified { schema_changed = true; _ }) -> + (* Both changed schema — apply strategy *) + let winner = + match strategy with + | PreferLeft -> Database.get_relation left_db name + | PreferRight -> Database.get_relation right_db name + | RevertToAncestor -> Some base_rel + in + ( Option.value winner ~default:base_rel, + [ SchemaConflict name ] ) + | _ -> + (* Only left changed schema — take left's relation *) + let left_rel = + Option.value + (Database.get_relation left_db name) + ~default:base_rel + in + (left_rel, []) + else (base_rel, []) + in + conflicts := schema_conflict @ !conflicts; + (* Apply tuple adds/removes from left *) + let merged_tree = + List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples + in + let merged_tree = + List.fold_left + (fun t h -> Merkle.delete h t) + merged_tree removed_tuples + in + (* Apply tuple adds/removes from right if disjoint *) + let merged_tree = + match right_diff with + | Some + (Diff.RelationModified { added_tuples = r_add; removed_tuples = r_rem; _ }) -> - (* Detect tuple conflicts: same hash both added and removed *) - let left_add = StringSet.of_list added_tuples in - let left_rem = StringSet.of_list removed_tuples in - let right_add = StringSet.of_list r_add in - let right_rem = StringSet.of_list r_rem in - let conflict_hashes = - StringSet.inter left_add right_rem - |> StringSet.union (StringSet.inter left_rem right_add) - in - if not (StringSet.is_empty conflict_hashes) then begin - StringSet.iter (fun h -> - conflicts := TupleConflict { relation = name; hash = h } :: !conflicts - ) conflict_hashes; - (* Resolve conflicting tuples per strategy *) - match strategy with - | PreferLeft -> - (* keep left's merged_tree as-is, ignore conflicting right ops *) - let safe_add = StringSet.diff right_add conflict_hashes in - let safe_rem = StringSet.diff right_rem conflict_hashes in - let t = StringSet.fold (fun h acc -> Merkle.insert h acc) safe_add merged_tree in - StringSet.fold (fun h acc -> Merkle.delete h acc) safe_rem t - | PreferRight -> - (* revert left's conflicting ops, apply right's *) - let t = StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree in - let t = StringSet.fold (fun h acc -> Merkle.insert h acc) right_add t in - StringSet.fold (fun h acc -> Merkle.delete h acc) right_rem t - | RevertToAncestor -> - (* drop conflicting hashes from merged tree *) - StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree - end else begin - (* Disjoint — union both sides *) - let t = List.fold_left (fun acc h -> Merkle.insert h acc) merged_tree r_add in - List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem - end - | _ -> merged_tree - in - let new_hash = Hashing.hash_relation - ~name:resolved_rel.Relation.name - ~schema:resolved_rel.Relation.schema - ~tree:merged_tree - in - let updated_rel = { resolved_rel with - Relation.tree = Some merged_tree; - hash = Some new_hash; - } in - let new_db = Database.update_relation db ~relation:updated_rel in - (new_db, !conflicts)) + (* Detect tuple conflicts: same hash both added and removed *) + let left_add = StringSet.of_list added_tuples in + let left_rem = StringSet.of_list removed_tuples in + let right_add = StringSet.of_list r_add in + let right_rem = StringSet.of_list r_rem in + let conflict_hashes = + StringSet.inter left_add right_rem + |> StringSet.union (StringSet.inter left_rem right_add) + in + if not (StringSet.is_empty conflict_hashes) then begin + StringSet.iter + (fun h -> + conflicts := + TupleConflict { relation = name; hash = h } + :: !conflicts) + conflict_hashes; + (* Resolve conflicting tuples per strategy *) + match strategy with + | PreferLeft -> + (* keep left's merged_tree as-is, ignore conflicting right ops *) + let safe_add = StringSet.diff right_add conflict_hashes in + let safe_rem = StringSet.diff right_rem conflict_hashes in + let t = + StringSet.fold + (fun h acc -> Merkle.insert h acc) + safe_add merged_tree + in + StringSet.fold + (fun h acc -> Merkle.delete h acc) + safe_rem t + | PreferRight -> + (* revert left's conflicting ops, apply right's *) + let t = + StringSet.fold + (fun h acc -> Merkle.delete h acc) + conflict_hashes merged_tree + in + let t = + StringSet.fold + (fun h acc -> Merkle.insert h acc) + right_add t + in + StringSet.fold + (fun h acc -> Merkle.delete h acc) + right_rem t + | RevertToAncestor -> + (* drop conflicting hashes from merged tree *) + StringSet.fold + (fun h acc -> Merkle.delete h acc) + conflict_hashes merged_tree + end + else begin + (* Disjoint — union both sides *) + let t = + List.fold_left + (fun acc h -> Merkle.insert h acc) + merged_tree r_add + in + List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem + end + | _ -> merged_tree + in + let new_hash = + Hashing.hash_relation ~name:resolved_rel.Relation.name + ~schema:resolved_rel.Relation.schema ~tree:merged_tree + in + let updated_rel = + { + resolved_rel with + Relation.tree = Some merged_tree; + hash = Some new_hash; + } + in + let new_db = Database.update_relation db ~relation:updated_rel in + (new_db, !conflicts)) module Make (Storage : Physical.S) - (Manip : MANIPULATION with type storage = Storage.t) = + (Manip : MANIPULATION with type storage = Storage.t) = struct - let err s = Error (Manip.of_string_error s) (* Load both tips, find the lowest common ancestor, compute the diffs, @@ -151,85 +184,103 @@ struct match Manip.load_database storage left_tip with | Error e -> Error e | Ok None -> err ("Left tip not found: " ^ left_tip) - | Ok (Some left_db) -> - match Manip.load_database storage right_tip with - | Error e -> Error e - | Ok None -> err ("Right tip not found: " ^ right_tip) - | Ok (Some right_db) -> - match find_lca left_db right_db with - | None -> err "No common ancestor found between branches" - | Some ancestor_hash -> - match Manip.load_database storage ancestor_hash with - | Error e -> Error e - | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) - | Ok (Some ancestor_db) -> - let left_diffs = Diff.diff ~ancestor:ancestor_db ~target:left_db in - let right_diffs = Diff.diff ~ancestor:ancestor_db ~target:right_db in - let right_diff_map = - List.fold_left (fun m d -> - let key = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - Database.RelationMap.add key d m - ) Database.RelationMap.empty right_diffs - in - let (merged_db, all_conflicts) = - let (db_after_left, left_conflicts) = - List.fold_left (fun (db, conflicts) left_d -> - let rel_name = match left_d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - let right_d = Database.RelationMap.find_opt rel_name right_diff_map in - let (new_db, cs) = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:left_d ~right_diff:right_d - in - (new_db, cs @ conflicts) - ) (ancestor_db, []) left_diffs - in - let left_names = - List.fold_left (fun s d -> - let n = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - StringSet.add n s - ) StringSet.empty left_diffs - in - let right_only = List.filter (fun d -> - let n = match d with - | Diff.RelationAdded r -> r.Relation.name - | Diff.RelationRemoved n -> n - | Diff.RelationModified { name; _ } -> name - in - not (StringSet.mem n left_names) - ) right_diffs in - let (db_final, right_conflicts) = - List.fold_left (fun (db, conflicts) right_d -> - let (new_db, cs) = - apply_diff db ~strategy ~left_db ~right_db - ~left_diff:right_d ~right_diff:None - in - (new_db, cs @ conflicts) - ) (db_after_left, left_conflicts) right_only - in - (db_final, right_conflicts) - in - let unresolvable = List.filter (function - | ConstraintConflict _ -> true - | _ -> false - ) all_conflicts in - if unresolvable <> [] then - Ok (Failed unresolvable) - else begin - match Manip.store_database storage merged_db with - | Error e -> Error e - | Ok () -> Ok (Clean merged_db) - end - + | Ok (Some left_db) -> ( + match Manip.load_database storage right_tip with + | Error e -> Error e + | Ok None -> err ("Right tip not found: " ^ right_tip) + | Ok (Some right_db) -> ( + match find_lca left_db right_db with + | None -> err "No common ancestor found between branches" + | Some ancestor_hash -> ( + match Manip.load_database storage ancestor_hash with + | Error e -> Error e + | Ok None -> err ("Ancestor not found: " ^ ancestor_hash) + | Ok (Some ancestor_db) -> + let left_diffs = + Diff.diff ~ancestor:ancestor_db ~target:left_db + in + let right_diffs = + Diff.diff ~ancestor:ancestor_db ~target:right_db + in + let right_diff_map = + List.fold_left + (fun m d -> + let key = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + Database.RelationMap.add key d m) + Database.RelationMap.empty right_diffs + in + let merged_db, all_conflicts = + let db_after_left, left_conflicts = + List.fold_left + (fun (db, conflicts) left_d -> + let rel_name = + match left_d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + let right_d = + Database.RelationMap.find_opt rel_name + right_diff_map + in + let new_db, cs = + apply_diff db ~strategy ~left_db ~right_db + ~left_diff:left_d ~right_diff:right_d + in + (new_db, cs @ conflicts)) + (ancestor_db, []) left_diffs + in + let left_names = + List.fold_left + (fun s d -> + let n = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + StringSet.add n s) + StringSet.empty left_diffs + in + let right_only = + List.filter + (fun d -> + let n = + match d with + | Diff.RelationAdded r -> r.Relation.name + | Diff.RelationRemoved n -> n + | Diff.RelationModified { name; _ } -> name + in + not (StringSet.mem n left_names)) + right_diffs + in + let db_final, right_conflicts = + List.fold_left + (fun (db, conflicts) right_d -> + let new_db, cs = + apply_diff db ~strategy ~left_db ~right_db + ~left_diff:right_d ~right_diff:None + in + (new_db, cs @ conflicts)) + (db_after_left, left_conflicts) + right_only + in + (db_final, right_conflicts) + in + let unresolvable = + List.filter + (function ConstraintConflict _ -> true | _ -> false) + all_conflicts + in + if unresolvable <> [] then Ok (Failed unresolvable) + else begin + match Manip.store_database storage merged_db with + | Error e -> Error e + | Ok () -> Ok (Clean merged_db) + end))) end diff --git a/lib/management/physical.ml b/lib/management/physical.ml index 6063d79..3fc2cf7 100644 --- a/lib/management/physical.ml +++ b/lib/management/physical.ml @@ -1,46 +1,48 @@ (** Physical storage abstraction. - This module defines a functor-based storage interface that can be backed - by any key-value store (etcd, Redis, DynamoDB, PostgreSQL, filesystem, etc.). + This module defines a functor-based storage interface that can be backed by + any key-value store (etcd, Redis, DynamoDB, PostgreSQL, filesystem, etc.). - All data is content-addressed: keys are hashes, values are serialized objects. - The storage is append-only - objects are never modified, only new versions - are written with new hashes. *) + All data is content-addressed: keys are hashes, values are serialized + objects. The storage is append-only - objects are never modified, only new + versions are written with new hashes. *) (** Backend module signature that any storage driver must implement *) module type BACKEND = sig type connection type error - (** Connect to the storage backend *) val connect : unit -> (connection, error) result + (** Connect to the storage backend *) - (** Disconnect from the backend *) val disconnect : connection -> unit + (** Disconnect from the backend *) - (** Get a value by its hash. Returns None if not found. *) val get : connection -> Conventions.Hash.t -> (bytes option, error) result + (** Get a value by its hash. Returns None if not found. *) - (** Store a value at its hash *) val put : connection -> Conventions.Hash.t -> bytes -> (unit, error) result + (** Store a value at its hash *) - (** Check if a hash exists *) val exists : connection -> Conventions.Hash.t -> (bool, error) result + (** Check if a hash exists *) - (** Begin a transaction *) val begin_transaction : connection -> (unit, error) result + (** Begin a transaction *) - (** Commit a transaction *) val commit : connection -> (unit, error) result + (** Commit a transaction *) - (** Rollback a transaction *) val rollback : connection -> (unit, error) result + (** Rollback a transaction *) + val get_many : + connection -> Conventions.Hash.t list -> (bytes option list, error) result (** Batch get multiple values *) - val get_many : connection -> Conventions.Hash.t list -> (bytes option list, error) result + val put_many : + connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result (** Batch put multiple values *) - val put_many : connection -> (Conventions.Hash.t * bytes) list -> (unit, error) result end (** Storage operations built on top of a backend *) @@ -48,29 +50,33 @@ module type S = sig type t type error - (** Create a storage instance from a backend connection *) val create : unit -> (t, error) result + (** Create a storage instance from a backend connection *) - (** Close the storage *) val close : t -> unit + (** Close the storage *) + val store_attribute : + t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result (** Store an attribute value, returns its hash *) - val store_attribute : t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, error) result + val load_attribute : + t -> + Conventions.Hash.t -> + (Conventions.AbstractValue.t option, error) result (** Load an attribute value by hash *) - val load_attribute : t -> Conventions.Hash.t -> (Conventions.AbstractValue.t option, error) result - (** Store raw bytes at a hash *) val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, error) result + (** Store raw bytes at a hash *) - (** Load raw bytes by hash *) val load_raw : t -> Conventions.Hash.t -> (bytes option, error) result + (** Load raw bytes by hash *) - (** Check if a hash exists *) val exists : t -> Conventions.Hash.t -> (bool, error) result + (** Check if a hash exists *) - (** Execute a function within a transaction *) val with_transaction : t -> (unit -> ('a, error) result) -> ('a, error) result + (** Execute a function within a transaction *) end (** Functor to create storage operations from a backend *) @@ -79,15 +85,12 @@ module Make (B : BACKEND) : S with type error = B.error = struct type error = B.error let create () = B.connect () - let close = B.disconnect let store_attribute conn value = let bytes = Marshal.to_bytes value [] in let hash = Conventions.AbstractValue.hash value in - match B.put conn hash bytes with - | Ok () -> Ok hash - | Error e -> Error e + match B.put conn hash bytes with Ok () -> Ok hash | Error e -> Error e let load_attribute conn hash = match B.get conn hash with @@ -95,27 +98,20 @@ module Make (B : BACKEND) : S with type error = B.error = struct | Ok None -> Ok None | Error e -> Error e - let store_raw conn hash bytes = - B.put conn hash bytes - - let load_raw conn hash = - B.get conn hash - - let exists conn hash = - B.exists conn hash + let store_raw conn hash bytes = B.put conn hash bytes + let load_raw conn hash = B.get conn hash + let exists conn hash = B.exists conn hash let with_transaction conn f = 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 + | 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) end (** In-memory backend for testing and development *) @@ -125,35 +121,34 @@ module MemoryBackend : BACKEND with type error = string = struct mutable in_transaction : bool; mutable transaction_buffer : (string * bytes) list; } + type error = string let connect () = - Ok { - data = Hashtbl.create 1024; - in_transaction = false; - transaction_buffer = []; - } + Ok + { + data = Hashtbl.create 1024; + in_transaction = false; + transaction_buffer = []; + } let disconnect _ = () - - let get conn hash = - Ok (Hashtbl.find_opt conn.data hash) + let get conn hash = Ok (Hashtbl.find_opt conn.data hash) let put conn hash value = if conn.in_transaction then begin conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer; Ok () - end else begin + end + else begin Hashtbl.replace conn.data hash value; Ok () end - let exists conn hash = - Ok (Hashtbl.mem conn.data hash) + let exists conn hash = Ok (Hashtbl.mem conn.data hash) let begin_transaction conn = - if conn.in_transaction then - Error "Already in transaction" + if conn.in_transaction then Error "Already in transaction" else begin conn.in_transaction <- true; conn.transaction_buffer <- []; @@ -161,20 +156,18 @@ module MemoryBackend : BACKEND with type error = string = struct end let commit conn = - if not conn.in_transaction then - Error "Not in transaction" + if not conn.in_transaction then 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 () end let rollback conn = - if not conn.in_transaction then - Error "Not in transaction" + if not conn.in_transaction then Error "Not in transaction" else begin conn.in_transaction <- false; conn.transaction_buffer <- []; @@ -185,14 +178,14 @@ module MemoryBackend : BACKEND with type error = string = struct 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 - ) 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) + pairs; Ok () end +module Memory = Make (MemoryBackend) (** Default in-memory storage for development *) -module Memory = Make(MemoryBackend) diff --git a/lib/merkle.ml b/lib/merkle.ml index ffa7171..6c4be52 100644 --- a/lib/merkle.ml +++ b/lib/merkle.ml @@ -2,57 +2,52 @@ This is an opaque interface that can be backed by different implementations: - A simple hash set (current placeholder) - - A proper radix/patricia merkle tree (e.g., plebeia when OCaml 5 support arrives) + - A proper radix/patricia merkle tree (e.g., plebeia when OCaml 5 support + arrives) - The tree stores hashes as keys (like a set) and computes a root hash - from all contained elements. *) + The tree stores hashes as keys (like a set) and computes a root hash from + all contained elements. *) module type S = sig type t - (** The empty tree *) val empty : t + (** The empty tree *) - (** Check if tree is empty *) val is_empty : t -> bool + (** Check if tree is empty *) - (** Insert a hash into the tree. Returns a new tree. *) val insert : Conventions.Hash.t -> t -> t + (** Insert a hash into the tree. Returns a new tree. *) - (** Delete a hash from the tree. Returns a new tree. *) val delete : Conventions.Hash.t -> t -> t + (** Delete a hash from the tree. Returns a new tree. *) - (** Check if a hash is in the tree *) val member : Conventions.Hash.t -> t -> bool + (** Check if a hash is in the tree *) - (** Get all hashes in the tree *) val keys : t -> Conventions.Hash.t list + (** Get all hashes in the tree *) - (** Compute the root hash of the tree. None if empty. *) val root_hash : t -> Conventions.Hash.t option + (** Compute the root hash of the tree. None if empty. *) - (** Number of elements in the tree *) val size : t -> int + (** Number of elements in the tree *) end -(** Simple hash set implementation. - This is a placeholder until a proper radix-merkle library - with OCaml 5 support becomes available. *) +(** Simple hash set implementation. This is a placeholder until a proper + radix-merkle library with OCaml 5 support becomes available. *) module HashSet : S = struct - module StringSet = Set.Make(String) + module StringSet = Set.Make (String) type t = StringSet.t let empty = StringSet.empty - let is_empty = StringSet.is_empty - let insert hash tree = StringSet.add hash tree - let delete hash tree = StringSet.remove hash tree - let member hash tree = StringSet.mem hash tree - let keys tree = StringSet.elements tree (* TODO: Streaming/pagination for large tuple sets. Currently materializes entire keyset into memory, which fails for relations with billions of tuples. @@ -60,10 +55,8 @@ module HashSet : S = struct to avoid loading all hashes upfront. Consider replacing HashSet with proper radix-merkle tree (plebeia) for native lazy traversal. *) - let root_hash tree = - if StringSet.is_empty tree then - None + if StringSet.is_empty tree then None else (* Compute root hash by hashing sorted concatenation of all hashes *) let sorted_hashes = StringSet.elements tree in @@ -73,5 +66,5 @@ module HashSet : S = struct let size = StringSet.cardinal end -(** Default implementation using HashSet *) include HashSet +(** Default implementation using HashSet *) diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml index 4a7241a..ce36f1e 100644 --- a/lib/prelude/catalog.ml +++ b/lib/prelude/catalog.ml @@ -1,39 +1,35 @@ -(** System catalog helpers. - Pure definitions — no storage access, no manipulation dependency. - Consumed by {!Manipulation.Make} to bootstrap and maintain the six - catalog relations that make the database self-describing. *) +(** System catalog helpers. Pure definitions — no storage access, no + manipulation dependency. Consumed by {!Manipulation.Make} to bootstrap and + maintain the six catalog relations that make the database self-describing. +*) (* TODO: on_rel_name and timing_rel_name are defined and seeded but never written to by any executor. They appear to be stubs for trigger/timing metadata that was never implemented. *) let catalog_prefix = "sakura:" - -let relation_rel_name = catalog_prefix ^ "relation" -let domain_rel_name = catalog_prefix ^ "domain" -let attribute_rel_name = catalog_prefix ^ "attribute" +let relation_rel_name = catalog_prefix ^ "relation" +let domain_rel_name = catalog_prefix ^ "domain" +let attribute_rel_name = catalog_prefix ^ "attribute" let constraint_rel_name = catalog_prefix ^ "constraint" -let on_rel_name = catalog_prefix ^ "on" -let timing_rel_name = catalog_prefix ^ "timing" -let branch_rel_name = catalog_prefix ^ "branch" -let head_rel_name = catalog_prefix ^ "head" +let on_rel_name = catalog_prefix ^ "on" +let timing_rel_name = catalog_prefix ^ "timing" +let branch_rel_name = catalog_prefix ^ "branch" +let head_rel_name = catalog_prefix ^ "head" let catalog_relation_names = - [ relation_rel_name - ; domain_rel_name - ; attribute_rel_name - ; constraint_rel_name - ; on_rel_name - ; timing_rel_name + [ + relation_rel_name; + domain_rel_name; + attribute_rel_name; + constraint_rel_name; + on_rel_name; + timing_rel_name; ] let is_catalog_relation name = List.mem name 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" +let relation_schema : Schema.t = Schema.empty |> Schema.add "name" "string" +let domain_schema : Schema.t = Schema.empty |> Schema.add "name" "string" let attribute_schema : Schema.t = Schema.empty @@ -42,23 +38,20 @@ let attribute_schema : Schema.t = |> Schema.add "domain_name" "string" let constraint_schema : Schema.t = - Schema.empty - |> Schema.add "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" +let on_schema : Schema.t = Schema.empty |> Schema.add "event" "string" +let timing_schema : Schema.t = Schema.empty |> Schema.add "timing" "string" 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) + [ + (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); ] (* TODO: all tuple builders use Obj.magic to coerce string values into @@ -66,51 +59,59 @@ let catalog_definitions = should use Obj.repr instead. *) let build_relation_tuple rel_name : Tuple.materialized = - { Tuple.relation = relation_rel_name - ; attributes = + { + Tuple.relation = relation_rel_name; + attributes = Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic rel_name } + { Attribute.value = Obj.magic rel_name }; } let build_domain_tuple dom_name : Tuple.materialized = - { Tuple.relation = domain_rel_name - ; attributes = + { + Tuple.relation = domain_rel_name; + attributes = Tuple.AttributeMap.singleton "name" - { Attribute.value = Obj.magic dom_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.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 }) - ] - } - ) schema +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.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 }); + ]; + }) + 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.relation = timing_rel_name; + attributes = Tuple.AttributeMap.singleton "timing" - { Attribute.value = Obj.magic timing } + { Attribute.value = Obj.magic timing }; } - diff --git a/lib/prelude/domains.ml b/lib/prelude/domains.ml index 29104bb..d892696 100644 --- a/lib/prelude/domains.ml +++ b/lib/prelude/domains.ml @@ -1,21 +1,19 @@ -(** Predefined fundamental domains, ported from the Erlang implementation. - Each domain carries a generator (for enumeration) and membership criteria - (for validation). Values are stored as {!Conventions.AbstractValue.t} via +(** Predefined fundamental domains, ported from the Erlang implementation. 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) + 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.)) + int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) in - let t = (w * (w + 1)) / 2 in + let t = w * (w + 1) / 2 in let b = n - t in let a = w - b in (a, b) @@ -26,84 +24,84 @@ let integer : Domain.t = let rec generator (position : int option) : Generator.result = 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) + 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." + 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 Domain.make ~name:"integer" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> + Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) -(** Natural number domain: non-negative integers (0, 1, 2, …). - Schema: [value: natural]. *) +(** Natural number domain: non-negative integers (0, 1, 2, …). Schema: + [value: natural]. *) let natural : Domain.t = 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) + 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." + 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 Domain.make ~name:"natural" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> + Stdlib.compare (Obj.magic a : int) (Obj.magic b : int)) (** Rational number domain: pairs [(numerator, denominator)] where the - denominator is never zero. The generator enumerates all such pairs via - Cantor pairing on the integers. - Schema: [numerator: integer, denominator: integer]. *) + denominator is never zero. The generator enumerates all such pairs via + Cantor pairing on the integers. Schema: + [numerator: integer, denominator: integer]. *) let rational : Domain.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_unpair n in - let num = nat_to_int a in - (* 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) ] - in - Generator.Value - (Tuple.make_materialized ~relation:"rational" ~attributes, generator) + let a, b = cantor_unpair n in + let num = nat_to_int a in + (* 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) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"rational" ~attributes, generator) | None -> - Generator.Error - "Cannot produce a randomly enumerated value for the rational domain." + 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 Domain.make ~name:"rational" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> Stdlib.compare (Obj.magic a : float) (Obj.magic b : float)) -(** String domain: any string value. Not enumerable. - Schema: [value: string]. *) +(** String domain: any string value. Not enumerable. Schema: [value: string]. *) let string : Domain.t = let generator (_ : int option) : Generator.result = Generator.Error "Strings are not enumerable." @@ -113,6 +111,5 @@ let string : Domain.t = | Tuple.NonMaterialized _ -> false in Domain.make ~name:"string" ~generator ~membership_criteria - ~cardinality:Conventions.Cardinality.AlephZero - ~compare:(fun a b -> + ~cardinality:Conventions.Cardinality.AlephZero ~compare:(fun a b -> String.compare (Obj.magic a : string) (Obj.magic b : string)) diff --git a/lib/prelude/standard.ml b/lib/prelude/standard.ml index 68012fc..6bdab0c 100644 --- a/lib/prelude/standard.ml +++ b/lib/prelude/standard.ml @@ -7,22 +7,23 @@ 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]. *) +(** 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.empty + |> Schema.add "left" domain_name |> Schema.add "right" domain_name in let membership_criteria : Tuple.t -> bool = 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) + match + ( Tuple.AttributeMap.find_opt "left" m.attributes, + Tuple.AttributeMap.find_opt "right" m.attributes ) + with + | Some l, Some r -> + pred (Stdlib.compare l.Attribute.value r.Attribute.value) + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name ~schema ~tree:None ~constraints:None @@ -33,38 +34,35 @@ let make_comparison ~name ~domain_name ~pred ~cardinality ~generator = (** Enumerate pairs (a, b) where a < b using triangular indexing. *) let pair_of_nat_lt n = let nf = float_of_int n in - let r = int_of_float (floor ((1. +. sqrt (1. +. 8. *. nf)) /. 2.)) in - let t_prev = (r * (r - 1)) / 2 in + 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) (** 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.)) + int_of_float (floor ((sqrt (float_of_int ((8 * n) + 1)) -. 1.) /. 2.)) in - let t = (w * (w + 1)) / 2 in + let t = w * (w + 1) / 2 in let b = n - t in let a = w - b in (a, b) - let less_than_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | 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) ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"less_than" ~attributes, - generator ) + 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) ] + in + Generator.Value + (Tuple.make_materialized ~relation:"less_than" ~attributes, generator) | None -> - Error - "Cannot produce a randomly enumerated value for less_than over \ - naturals." + 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) @@ -74,17 +72,16 @@ let less_than_or_equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - let a, b = cantor_pair_of_nat n in - (* 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 - Generator.Value - ( Tuple.make_materialized ~relation:"less_than_or_equal" ~attributes, - generator ) + let a, b = cantor_pair_of_nat n in + (* 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 + Generator.Value + ( 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" @@ -96,15 +93,14 @@ let greater_than_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | 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 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 ) | None -> Error "Cannot enumerate greater_than randomly." in make_comparison ~name:"natural_natural_greater_than" ~domain_name:"natural" @@ -115,16 +111,15 @@ let greater_than_or_equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | Some n -> - 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 - Generator.Value - ( Tuple.make_materialized ~relation:"greater_than_or_equal" ~attributes, - generator ) + 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 + Generator.Value + ( 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" @@ -136,12 +131,11 @@ let equal_natural : Relation.t = 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" @@ -152,21 +146,19 @@ let not_equal_natural : Relation.t = let rec generator (position : int option) : Generator.result = 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 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) | None -> Error "Cannot enumerate not_equal randomly." in make_comparison ~name:"natural_natural_not_equal" ~domain_name:"natural" ~pred:(fun c -> c <> 0) ~cardinality:Conventions.Cardinality.AlephZero ~generator - let plus_natural : Relation.t = let schema = Schema.empty |> Schema.add "a" "natural" |> Schema.add "b" "natural" @@ -175,175 +167,159 @@ let plus_natural : Relation.t = let rec generator (position : int option) : Generator.result = match position with | 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 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) | None -> Error "Cannot enumerate plus randomly." in let membership_criteria : Tuple.t -> bool = 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) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "sum" m.attributes ) + with + | Some a, Some b, Some s -> + (Obj.magic a.Attribute.value : int) + + (Obj.magic b.Attribute.value : int) + = (Obj.magic s.Attribute.value : int) + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_plus" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "plus") ~lineage:(Relation.Lineage.Base "plus") let times_natural : Relation.t = 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 = match position with | 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 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) | None -> Error "Cannot enumerate times randomly." in let membership_criteria : Tuple.t -> bool = 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) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "product" m.attributes ) + with + | Some a, Some b, Some p -> + (Obj.magic a.Attribute.value : int) + * (Obj.magic b.Attribute.value : int) + = (Obj.magic p.Attribute.value : int) + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_times" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "times") ~lineage:(Relation.Lineage.Base "times") let minus_natural : Relation.t = 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 = match position with | Some n -> - (* 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 ) + (* 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) | None -> Error "Cannot enumerate minus randomly." in let membership_criteria : Tuple.t -> bool = function | Tuple.Materialized m -> ( - match - ( Tuple.AttributeMap.find_opt "a" m.attributes, - Tuple.AttributeMap.find_opt "b" m.attributes, - Tuple.AttributeMap.find_opt "difference" m.attributes ) - with - | Some a, Some b, Some d -> - let av = (Obj.magic a.Attribute.value : int) in - let bv = (Obj.magic b.Attribute.value : int) in - let dv = (Obj.magic d.Attribute.value : int) in - av - bv = dv && dv >= 0 - | _ -> false) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "difference" m.attributes ) + with + | Some a, Some b, Some d -> + let av = (Obj.magic a.Attribute.value : int) in + let bv = (Obj.magic b.Attribute.value : int) in + let dv = (Obj.magic d.Attribute.value : int) in + av - bv = dv && dv >= 0 + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_minus" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "minus") ~lineage:(Relation.Lineage.Base "minus") let divide_natural : Relation.t = 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 let rec generator (position : int option) : Generator.result = match position with | Some n -> - (* Enumerate (b, q, r) triples where b > 0, then a = b*q + r, 0 <= r < b *) - (* We use a nested Cantor pairing: n -> (b_idx, qr_idx) -> (q, r) *) - let b_idx, qr_idx = cantor_pair_of_nat n in - let b = b_idx + 1 in (* b > 0 *) - let q, r_raw = cantor_pair_of_nat qr_idx in - 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); - ] - in - Generator.Value - ( Tuple.make_materialized ~relation:"divide" ~attributes, generator ) + (* Enumerate (b, q, r) triples where b > 0, then a = b*q + r, 0 <= r < b *) + (* We use a nested Cantor pairing: n -> (b_idx, qr_idx) -> (q, r) *) + let b_idx, qr_idx = cantor_pair_of_nat n in + let b = b_idx + 1 in + (* b > 0 *) + let q, r_raw = cantor_pair_of_nat qr_idx in + 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); + ] + in + Generator.Value + (Tuple.make_materialized ~relation:"divide" ~attributes, generator) | None -> Error "Cannot enumerate divide randomly." in let membership_criteria : Tuple.t -> bool = 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) + match + ( Tuple.AttributeMap.find_opt "a" m.attributes, + Tuple.AttributeMap.find_opt "b" m.attributes, + Tuple.AttributeMap.find_opt "quotient" m.attributes, + Tuple.AttributeMap.find_opt "remainder" m.attributes ) + with + | Some a, Some b, Some q, Some r -> + let av = (Obj.magic a.Attribute.value : int) in + let bv = (Obj.magic b.Attribute.value : int) in + let qv = (Obj.magic q.Attribute.value : int) in + let rv = (Obj.magic r.Attribute.value : int) in + bv > 0 && av = (bv * qv) + rv && rv >= 0 && rv < bv + | _ -> false) | Tuple.NonMaterialized _ -> false in Relation.make ~hash:None ~name:"natural_divide" ~schema ~tree:None - ~constraints:None - ~cardinality:Conventions.Cardinality.AlephZero + ~constraints:None ~cardinality:Conventions.Cardinality.AlephZero ~generator:(Some generator) ~membership_criteria ~provenance:(Relation.Provenance.Base "divide") ~lineage:(Relation.Lineage.Base "divide") diff --git a/lib/relation.ml b/lib/relation.ml index 0773c6c..285bcef 100644 --- a/lib/relation.ml +++ b/lib/relation.ml @@ -1,5 +1,5 @@ -(** Use the Merkle module for tuple hash storage *) module Tree = Merkle +(** Use the Merkle module for tuple hash storage *) module RelationConstraint = struct type name = string @@ -54,4 +54,4 @@ let make ~hash ~name ~schema ~tree ~constraints ~cardinality ~generator membership_criteria; provenance; lineage; - }
\ No newline at end of file + } diff --git a/lib/schema.ml b/lib/schema.ml index e17f7a5..923284a 100644 --- a/lib/schema.ml +++ b/lib/schema.ml @@ -1,7 +1,7 @@ (** Schema: maps attribute names to domain/type names. - A schema defines the structure of a relation by listing each attribute - and its associated domain (type). This is used for: + A schema defines the structure of a relation by listing each attribute and + its associated domain (type). This is used for: - Hashing relations (schema is part of the relation identity) - Validation (checking tuple membership) - Persistence (storing and loading relations with their structure) *) @@ -9,13 +9,8 @@ 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 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 "," + List.map (fun (n, t) -> n ^ ":" ^ t) schema |> String.concat "," diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml index 6cb17b8..d48d852 100644 --- a/lib/scl/executor.ml +++ b/lib/scl/executor.ml @@ -6,72 +6,68 @@ type cursor_batch = { has_more : bool; } -type exec_result = - | Batch of cursor_batch - | Closed of Management.Database.t +type exec_result = Batch of cursor_batch | Closed of Management.Database.t let sessions : Session.t option ref = ref None - let set_sessions s = sessions := Some s module Make (Storage : Management.Physical.S) = struct - module DrlExec = Drl.Executor.Make(Storage) - module Alg = Algebra.Make(Storage) + module DrlExec = Drl.Executor.Make (Storage) + module Alg = Algebra.Make (Storage) type error = - | ParseError of string - | QueryError of DrlExec.error + | ParseError of string + | QueryError of DrlExec.error | CursorError of string let sexp_of_error e = let open Sexplib.Sexp in match e with - | ParseError s -> List [Atom "parse-error"; Atom s] - | QueryError e -> DrlExec.sexp_of_error e - | CursorError s -> List [Atom "cursor-error"; Atom s] + | ParseError s -> List [ Atom "parse-error"; Atom s ] + | QueryError e -> DrlExec.sexp_of_error e + | CursorError s -> List [ Atom "cursor-error"; Atom s ] let get_sessions () = match !sessions with | Some s -> Ok s - | None -> Error (CursorError "The session registry has not been initialised; ensure `set_sessions` is called at startup.") + | None -> + Error + (CursorError + "The session registry has not been initialised; ensure \ + `set_sessions` is called at startup.") let ( let* ) = Result.bind - let execute - (storage : Storage.t) - (db : Management.Database.t) - (stmt : Ast.statement) - : (exec_result, error) result = + let execute (storage : Storage.t) (db : Management.Database.t) + (stmt : Ast.statement) : (exec_result, error) result = match stmt with | Ast.Begin { query; limit } -> - let* reg = get_sessions () in - let* rel = - DrlExec.execute storage db query - |> Result.map_error (fun e -> QueryError e) - in - let gen = Alg.to_generator storage rel in - let query_str = Drl.Parser.to_string query in - let cur = Session.register reg ~db ~query:query_str ~generator:gen in - let batch = Option.value ~default:default_batch limit in - let* (rows, has_more) = - Session.fetch reg ~id:cur.Session.id ~limit:batch - |> Result.map_error (fun s -> CursorError s) - in - Ok (Batch { cursor_id = cur.Session.id; rows; has_more }) - + let* reg = get_sessions () in + let* rel = + DrlExec.execute storage db query + |> Result.map_error (fun e -> QueryError e) + in + let gen = Alg.to_generator storage rel in + let query_str = Drl.Parser.to_string query in + let cur = Session.register reg ~db ~query:query_str ~generator:gen in + let batch = Option.value ~default:default_batch limit in + let* rows, has_more = + Session.fetch reg ~id:cur.Session.id ~limit:batch + |> Result.map_error (fun s -> CursorError s) + in + Ok (Batch { cursor_id = cur.Session.id; rows; has_more }) | Ast.Fetch { cursor; limit } -> - let* reg = get_sessions () in - let batch = Option.value ~default:default_batch limit in - let* (rows, has_more) = - Session.fetch reg ~id:cursor ~limit:batch - |> Result.map_error (fun s -> CursorError s) - in - Ok (Batch { cursor_id = cursor; rows; has_more }) - + let* reg = get_sessions () in + let batch = Option.value ~default:default_batch limit in + let* rows, has_more = + Session.fetch reg ~id:cursor ~limit:batch + |> Result.map_error (fun s -> CursorError s) + in + Ok (Batch { cursor_id = cursor; rows; has_more }) | Ast.Close { cursor } -> - let* reg = get_sessions () in - Session.close reg ~id:cursor; - Ok (Closed db) + let* reg = get_sessions () in + Session.close reg ~id:cursor; + Ok (Closed db) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml index 7098ced..b39e720 100644 --- a/lib/scl/sublanguage.ml +++ b/lib/scl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "scl" @@ -16,11 +16,10 @@ module Make (Storage : Management.Physical.S) = struct Exec.execute storage db ast |> Result.map (function | Executor.Batch { cursor_id; rows; has_more } -> - Sublanguage.Cursor { cursor_id; rows; has_more } - | Executor.Closed db -> - Sublanguage.Transition (db, "cursor closed")) + Sublanguage.Cursor { cursor_id; rows; has_more } + | Executor.Closed db -> Sublanguage.Transition (db, "cursor closed")) let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/session.ml b/lib/session.ml index 272a419..a58d00b 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1,8 +1,8 @@ (** Cursor registry for streaming tuple consumption. - Each cursor wraps a [Generator.t] produced by a DRL query and - tracks the current position so that successive [fetch] calls - return the next batch of rows without replaying the query. *) + Each cursor wraps a [Generator.t] produced by a DRL query and tracks the + current position so that successive [fetch] calls return the next batch of + rows without replaying the query. *) type cursor = { id : string; @@ -13,70 +13,67 @@ type cursor = { created_at : float; } -type t = { - tbl : (string, cursor) Hashtbl.t; - mutable counter : int; -} +type t = { tbl : (string, cursor) Hashtbl.t; mutable counter : int } -let create () : t = - { tbl = Hashtbl.create 16; counter = 0 } +let create () : t = { tbl = Hashtbl.create 16; counter = 0 } let register (reg : t) ~(db : Management.Database.t) ~(query : string) ~(generator : Generator.t) : cursor = let raw = string_of_int reg.counter ^ query ^ db.Management.Database.hash in let id = Conventions.Hash.hash_text raw in reg.counter <- reg.counter + 1; - let cur = { - id; - generator; - position = 0; - db_snapshot = db; - query_sexp = query; - created_at = Unix.gettimeofday (); - } in + let cur = + { + id; + generator; + position = 0; + db_snapshot = db; + query_sexp = query; + created_at = Unix.gettimeofday (); + } + in Hashtbl.replace reg.tbl id cur; cur -let fetch (reg : t) ~(id : string) ~(limit : int) - : (Tuple.materialized list * bool, string) result = +let fetch (reg : t) ~(id : string) ~(limit : int) : + (Tuple.materialized list * bool, string) result = match Hashtbl.find_opt reg.tbl id with - | None -> Error ("The cursor with identifier `" ^ id ^ "` was not found in the session registry.") + | None -> + Error + ("The cursor with identifier `" ^ id + ^ "` was not found in the session registry.") | Some cur -> - let rec go gen pos acc count = - if count >= limit then (List.rev acc, gen, pos, true) - else - match gen (Some pos) with - | Generator.Done -> (List.rev acc, gen, pos, false) - (* Generator errors are treated as exhaustion: the partial batch is + let rec go gen pos acc count = + if count >= limit then (List.rev acc, gen, pos, true) + else + match gen (Some pos) with + | Generator.Done -> (List.rev acc, gen, pos, false) + (* Generator errors are treated as exhaustion: the partial batch is returned with has_more = false and the cursor is auto-removed. The caller receives no indication that the stream terminated abnormally. When fetch gains a richer return type this arm should surface the error message instead. *) - | Generator.Error _ -> (List.rev acc, gen, pos, false) - | Generator.Value (t, next) -> - begin match t with - | Tuple.Materialized m -> - go next (pos + 1) (m :: acc) (count + 1) - | Tuple.NonMaterialized _ -> - go next (pos + 1) acc count - end - in - let (rows, gen', pos', has_more) = - go cur.generator cur.position [] 0 - in - cur.generator <- gen'; - cur.position <- pos'; - if not has_more then Hashtbl.remove reg.tbl id; - Ok (rows, has_more) + | Generator.Error _ -> (List.rev acc, gen, pos, false) + | Generator.Value (t, next) -> begin + match t with + | Tuple.Materialized m -> go next (pos + 1) (m :: acc) (count + 1) + | Tuple.NonMaterialized _ -> go next (pos + 1) acc count + end + in + let rows, gen', pos', has_more = go cur.generator cur.position [] 0 in + cur.generator <- gen'; + cur.position <- pos'; + if not has_more then Hashtbl.remove reg.tbl id; + Ok (rows, has_more) -let close (reg : t) ~(id : string) : unit = - Hashtbl.remove reg.tbl id +let close (reg : t) ~(id : string) : unit = Hashtbl.remove reg.tbl id let gc (reg : t) ~(max_age : float) : unit = let now = Unix.gettimeofday () in let to_remove = - Hashtbl.fold (fun k cur acc -> - if now -. cur.created_at >= max_age then k :: acc else acc) + Hashtbl.fold + (fun k cur acc -> + if now -. cur.created_at >= max_age then k :: acc else acc) reg.tbl [] in List.iter (Hashtbl.remove reg.tbl) to_remove diff --git a/lib/storable.ml b/lib/storable.ml index 058773c..ec0bce2 100644 --- a/lib/storable.ml +++ b/lib/storable.ml @@ -3,7 +3,8 @@ These modules define the wire format for persisting relational engine objects to storage. Each type has to_bytes/of_bytes for serialization. - The stored formats capture only the essential data needed for reconstruction: + The stored formats capture only the essential data needed for + reconstruction: - Tuple: relation name and attribute hashes - Relation: name, schema, tuple hashes, cardinality - Database: name, relation hashes, merkle tree keys, history *) @@ -12,14 +13,12 @@ module Tuple = struct type t = { relation : string; - attributes : (string * Conventions.Hash.t) list; (* attr_name -> attr_value_hash *) + attributes : (string * Conventions.Hash.t) list; + (* attr_name -> attr_value_hash *) } - let to_bytes (st : t) : bytes = - Marshal.to_bytes st [Marshal.Closures] - - let of_bytes (b : bytes) : t = - Marshal.from_bytes b 0 + let to_bytes (st : t) : bytes = Marshal.to_bytes st [ Marshal.Closures ] + let of_bytes (b : bytes) : t = Marshal.from_bytes b 0 end (** Stored relation format for serialization *) @@ -27,30 +26,26 @@ module Relation = struct type t = { name : string; schema : Schema.t; - tree_keys : Conventions.Hash.t list; (* Merkle tree contents - tuple hashes *) + tree_keys : Conventions.Hash.t list; + (* Merkle tree contents - tuple hashes *) cardinality : Conventions.Cardinality.t; } - let to_bytes (sr : t) : bytes = - Marshal.to_bytes sr [Marshal.Closures] - - let of_bytes (b : bytes) : t = - Marshal.from_bytes b 0 + let to_bytes (sr : t) : bytes = Marshal.to_bytes sr [ Marshal.Closures ] + let of_bytes (b : bytes) : t = Marshal.from_bytes b 0 end (** Stored database format for serialization *) module Database = struct type t = { name : string; - relations : (string * Conventions.Hash.t) list; (* name -> relation_hash *) - tree_keys : Conventions.Hash.t list; (* Merkle tree contents - relation hashes *) + relations : (string * Conventions.Hash.t) list; (* name -> relation_hash *) + tree_keys : Conventions.Hash.t list; + (* Merkle tree contents - relation hashes *) history : Conventions.Hash.t list; timestamp : float; } - let to_bytes (sd : t) : bytes = - Marshal.to_bytes sd [Marshal.Closures] - - let of_bytes (b : bytes) : t = - Marshal.from_bytes b 0 + let to_bytes (sd : t) : bytes = Marshal.to_bytes sd [ Marshal.Closures ] + let of_bytes (b : bytes) : t = Marshal.from_bytes b 0 end diff --git a/lib/sublanguage.ml b/lib/sublanguage.ml index d92358e..4cfe913 100644 --- a/lib/sublanguage.ml +++ b/lib/sublanguage.ml @@ -1,24 +1,24 @@ +type cursor_result = { + cursor_id : string; + rows : Tuple.materialized list; + has_more : bool; +} (** Effect classification for sublanguage operations. Categorically: - Query: a natural transformation between instance functors (DRL). Side-effect-free; the database state is unchanged. - - Transition: a morphism in the category of database states (DDL, - DML, ICL, DCL, and future TCL). Produces a new state via - substitution (Harper, PFPL ch. 3-4). + - Transition: a morphism in the category of database states (DDL, DML, ICL, + DCL, and future TCL). Produces a new state via substitution (Harper, PFPL + ch. 3-4). Future sublanguages: - - TCL -> Transition (transaction boundaries are state morphisms - with atomicity constraints) + - TCL -> Transition (transaction boundaries are state morphisms with + atomicity constraints) - PPL -> new effect class: potentially non-terminating computation (Turing-complete; breaks the termination guarantee of DRL) - ACL -> a functor restriction: narrows the admissible natural transformations based on authorization context *) -type cursor_result = { - cursor_id : string; - rows : Tuple.materialized list; - has_more : bool; -} type result = | Query of Relation.t @@ -29,8 +29,12 @@ module type S = sig type storage type ast type error + val name : string val parse_sexp : Sexplib.Sexp.t -> (ast, error) Result.t - val execute : storage -> Management.Database.t -> ast -> (result, error) Result.t + + val execute : + storage -> Management.Database.t -> ast -> (result, error) Result.t + val sexp_of_error : error -> Sexplib.Sexp.t end diff --git a/lib/tuple.ml b/lib/tuple.ml index 11fc508..1ce73b0 100644 --- a/lib/tuple.ml +++ b/lib/tuple.ml @@ -1,8 +1,10 @@ module AttributeMap = struct - include Map.Make(String) + include Map.Make (String) + 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]) + (List.map + (fun (k, v) -> Sexplib.Sexp.List [ Sexplib.Sexp.Atom k; sexp_of_v v ]) (bindings m)) end @@ -10,16 +12,17 @@ type non_materialized = { hash : Conventions.Hash.t; relation : Conventions.Name.t; attributes : Attribute.referenced AttributeMap.t; -} [@@deriving sexp_of] +} +[@@deriving sexp_of] type materialized = { - relation: Conventions.Name.t; - attributes: Attribute.materialized AttributeMap.t; -} [@@deriving sexp_of] + relation : Conventions.Name.t; + attributes : Attribute.materialized AttributeMap.t; +} +[@@deriving sexp_of] -type t = - | Materialized of materialized - | NonMaterialized of non_materialized +type t = Materialized of materialized | NonMaterialized of non_materialized [@@deriving sexp_of] -let make_materialized ~relation ~attributes = Materialized { relation; attributes } +let make_materialized ~relation ~attributes = + Materialized { relation; attributes } |