aboutsummaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorMarcos Magueta <maguetamarcos@gmail.com>2026-09-26 15:30:53 -0300
committerMarcos Magueta <maguetamarcos@gmail.com>2026-09-26 15:30:53 -0300
commite32ba6294781691846c3ab19281fe977350b4d0f (patch)
treef38e92ba2fc03e966d7263c7ee2e0b5d7983ebae /lib
parentbe375a52da6174dfda5b68617d27e1542cc80499 (diff)
downloadSakura-e32ba6294781691846c3ab19281fe977350b4d0f.tar.gz
Sakura-e32ba6294781691846c3ab19281fe977350b4d0f.zip
preparation cleanup for RNT integration
Diffstat (limited to 'lib')
-rw-r--r--lib/algebra.ml31
-rw-r--r--lib/attribute.ml10
-rw-r--r--lib/branch.ml219
-rw-r--r--lib/constraint.ml601
-rw-r--r--lib/conventions.ml55
-rw-r--r--lib/ddl/ast.ml12
-rw-r--r--lib/ddl/executor.ml81
-rw-r--r--lib/ddl/parser.ml17
-rw-r--r--lib/ddl/sublanguage.ml15
-rw-r--r--lib/dml/ast.ml19
-rw-r--r--lib/dml/executor.ml228
-rw-r--r--lib/dml/parser.ml17
-rw-r--r--lib/dml/sublanguage.ml15
-rw-r--r--lib/error.ml35
-rw-r--r--lib/hashing.ml52
-rw-r--r--lib/icl/ast.ml17
-rw-r--r--lib/icl/executor.ml53
-rw-r--r--lib/icl/parser.ml17
-rw-r--r--lib/icl/sublanguage.ml15
-rw-r--r--lib/management/branch.ml137
-rw-r--r--lib/management/multigroup.ml59
-rw-r--r--lib/management/physical.ml198
-rw-r--r--lib/manipulation.ml114
-rw-r--r--lib/nt_ffi.ml178
-rw-r--r--lib/prl/ast.ml15
-rw-r--r--lib/prl/executor.ml38
-rw-r--r--lib/prl/parser.ml14
-rw-r--r--lib/prl/runtime.ml75
-rw-r--r--lib/prl/sublanguage.ml11
-rw-r--r--lib/qualified_name.ml38
-rw-r--r--lib/qualified_name.mli16
-rw-r--r--lib/relation.ml189
-rw-r--r--lib/schema.ml14
-rw-r--r--lib/scl/ast.ml7
-rw-r--r--lib/scl/executor.ml29
-rw-r--r--lib/scl/parser.ml22
-rw-r--r--lib/scl/sublanguage.ml17
-rw-r--r--lib/storable.ml125
-rw-r--r--lib/tuple.ml26
-rw-r--r--lib/vcl/ast.ml1
-rw-r--r--lib/vcl/executor.ml9
-rw-r--r--lib/vcl/sublanguage.ml22
42 files changed, 0 insertions, 2863 deletions
diff --git a/lib/algebra.ml b/lib/algebra.ml
deleted file mode 100644
index 5416f65..0000000
--- a/lib/algebra.ml
+++ /dev/null
@@ -1,31 +0,0 @@
-(* algebra.ml — plan compilation support.
- Generator-based evaluation is removed; all query execution goes through the
- Tarski VM via Nt.execute_query. This module retains only what is needed to
- construct plan nodes and handle compile-time errors. *)
-
-type error = UnsupportedOperator of string
-
-(* const_relation is kept for the Ast.Const case which produces an in-memory
- ephemeral relation from literal pairs. It is used only in DRL tests and
- REPL exploration; it does not go through the VM.
- TODO: materialise const tuples into InMemoryBackend and SCAN them so they
- can participate in VM JOINs. *)
-let const_relation (pairs : (string * Conventions.AbstractValue.t) list) : Relation.ephemeral =
- let make_gen () =
- 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 gen = function
- | None | Some 0 -> Generator.Value (tuple, fun _ -> Generator.Done)
- | _ -> Generator.Done
- in
- gen
- in
- let schema = List.map (fun (k, _) -> k, "abstract") pairs in
- new Relation.ephemeral
- ~name:"const" ~schema ~constraints:None ~cardinality:(Conventions.Cardinality.Finite 1)
- ~membership_criteria:(fun _ -> true)
- ~lineage:None ~provenance:None ~generator:(make_gen ())
diff --git a/lib/attribute.ml b/lib/attribute.ml
deleted file mode 100644
index dc0e178..0000000
--- a/lib/attribute.ml
+++ /dev/null
@@ -1,10 +0,0 @@
-type referenced = {value_hash: Conventions.Hash.t} [@@deriving sexp_of]
-type materialized = {value: Conventions.AbstractValue.t} [@@deriving sexp_of]
-type t = Referenced of referenced | Materialized of materialized [@@deriving sexp_of]
-
-let make_referenced ~value =
- let value_hash = Conventions.AbstractValue.hash value in
- Referenced {value_hash}
-
-let make_materialized ~value = Materialized {value}
-let materialized_equal a b = Conventions.AbstractValue.equal a.value b.value
diff --git a/lib/branch.ml b/lib/branch.ml
deleted file mode 100644
index e153fa2..0000000
--- a/lib/branch.ml
+++ /dev/null
@@ -1,219 +0,0 @@
-(* Branch: the effectful session layer.
- Owns the RNT branch handle and the in-memory mirror of every multigroup
- bound to that branch. Each mutation names its target mg explicitly. *)
-
-module Make (NT : Nt.S) = struct
- module Error = struct
- open Condition
-
- (* TODO: more structure *)
- let not_supported msg = condition "not-supported" msg empty
- let handle_error msg = condition "handle-error" msg empty
- end
-
- let ( let* ) = Result.bind
-
- type mode =
- | Live (* tracking branch tip; mutations allowed *)
- | Detached of string (* pinned to snapshot hash; read-only *)
-
- class branch ~(init_bh : Nt.branch_handle) ~(init_name : string) ~(init_tip : string)
- ~(init_mgs : (string * Management.Multigroup.multigroup) list) ~(init_mode : mode) =
- object (self)
- val mutable bh : Nt.branch_handle = init_bh
- val name : string = init_name
- val mutable tip : string = init_tip
- val mutable mode : mode = init_mode
-
- val mgs : (string, Management.Multigroup.multigroup) Hashtbl.t =
- let t = Hashtbl.create 8 in
- List.iter (fun (n, mg) -> Hashtbl.replace t n mg) init_mgs;
- t
-
- method name = name
- method tip = tip
- method snapshot = tip
- method mode = mode
- method branch_handle = bh
- method mg_of (n : string) : Management.Multigroup.multigroup option = Hashtbl.find_opt mgs n
-
- method multigroups : (string * Management.Multigroup.multigroup) list =
- Hashtbl.to_seq mgs |> List.of_seq
-
- (* Register a fresh mg under this branch. Idempotent. *)
- method add_multigroup ~(name : string) : unit =
- if not (Hashtbl.mem mgs name) then
- Hashtbl.add mgs name (new Management.Multigroup.multigroup ~name)
-
- (* Replace the cached mg value (e.g. after an NT mutation returned a
- new mg). Idempotent insert if the mg was not present. *)
- method set_mg ~(name : string) (mg : Management.Multigroup.multigroup) : unit =
- Hashtbl.replace mgs name mg
-
- (* Path for a relation in this branch (Live) or its pinned snapshot
- (Detached). Pass [~branch] to reference a relation on a different
- live branch (cross-multigroup reads). *)
- method path ?(branch : string option) (fqn : Qualified_name.t) : string =
- match branch with
- | Some b -> "/system/branches/" ^ b ^ "/multigroups/" ^ fqn.mg ^ "/relations/" ^ fqn.name
- | None -> (
- match mode with
- | Live -> "/system/branches/" ^ name ^ "/multigroups/" ^ fqn.mg ^ "/relations/" ^ fqn.name
- | Detached hash -> "/system/snapshots/" ^ hash ^ "/relations/" ^ fqn.name )
-
- method private assert_live op =
- match mode with
- | Live -> Ok ()
- | Detached _ -> Error (Error.not_supported (op ^ ": detached snapshot is read-only"))
-
- method private sync_tip () =
- match mode with
- | Detached _ -> ()
- | Live -> ( match NT.branch_target_of_handle bh with Error _ -> () | Ok h -> tip <- h )
-
- method private get_mg op (mg_name : string) :
- (Management.Multigroup.multigroup, Condition.t) result =
- match Hashtbl.find_opt mgs mg_name with
- | Some mg -> Ok mg
- | None -> Error (Error.handle_error (op ^ ": multigroup not found: " ^ mg_name))
-
- method create_relation ~(mg : string) ~(rel_name : string) ~schema =
- let* () = self#assert_live "create_relation" in
- let* mg_val = self#get_mg "create_relation" mg in
- let* bh', mg' = NT.create_relation bh mg_val ~branch_name:name ~name:rel_name ~schema in
- bh <- bh';
- Hashtbl.replace mgs mg mg';
- self#sync_tip ();
- Ok ()
-
- method retract_relation ~(mg : string) ~(rel_name : string) =
- let* () = self#assert_live "retract_relation" in
- let* mg_val = self#get_mg "retract_relation" mg in
- let* bh', mg' = NT.retract_relation bh mg_val ~name:rel_name in
- bh <- bh';
- Hashtbl.replace mgs mg mg';
- self#sync_tip ();
- Ok ()
-
- method clear_relation ~(mg : string) ~(rel_name : string) =
- let* () = self#assert_live "clear_relation" in
- let* mg_val = self#get_mg "clear_relation" mg in
- match mg_val#get_relation rel_name with
- | None -> Error (Error.handle_error ("relation not found: " ^ rel_name))
- | Some rel ->
- let* bh', mg' = NT.clear_relation bh mg_val ~branch_name:name ~mg_name:mg rel in
- bh <- bh';
- Hashtbl.replace mgs mg mg';
- self#sync_tip ();
- Ok ()
-
- method register_domain ~(mg : string) domain =
- let* () = self#assert_live "register_domain" in
- let* mg_val = self#get_mg "register_domain" mg in
- let* bh', mg' = NT.register_domain bh mg_val domain in
- bh <- bh';
- Hashtbl.replace mgs mg mg';
- Ok ()
-
- method create_immutable_relation ~(mg : string) ~name:rel_name ~schema ~generator
- ~membership_criteria ~cardinality ~producer =
- let* () = self#assert_live "create_immutable_relation" in
- let* mg_val = self#get_mg "create_immutable_relation" mg in
- let* bh', mg', rel =
- NT.create_immutable_relation bh mg_val ~name:rel_name ~schema ~generator
- ~membership_criteria ~cardinality ~producer
- in
- bh <- bh';
- Hashtbl.replace mgs mg mg';
- Ok rel
-
- method register_constraint ~(mg : string) ~constraint_name ~relation_name ~body =
- let* () = self#assert_live "register_constraint" in
- let* mg_val = self#get_mg "register_constraint" mg in
- let* bh', mg' = NT.register_constraint bh mg_val ~constraint_name ~relation_name ~body in
- bh <- bh';
- Hashtbl.replace mgs mg mg';
- Ok ()
-
- method insert_tuple ~(mg : string) ~(rel_name : string) attrs =
- let* () = self#assert_live "insert_tuple" in
- let* hash = NT.insert_tuple ~branch_name:name ~mg_name:mg ~rel_name attrs in
- self#sync_tip (); Ok hash
-
- method create_tuple ~(mg : string) ~(rel_name : string) tuple =
- let* () = self#assert_live "create_tuple" in
- let* hash = NT.create_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple in
- self#sync_tip (); Ok hash
-
- method create_tuples ~(mg : string) ~(rel_name : string) tuples =
- let* () = self#assert_live "create_tuples" in
- let* hash = NT.create_tuples ~branch_name:name ~mg_name:mg ~rel_name tuples in
- self#sync_tip (); Ok hash
-
- method retract_tuple ~(mg : string) ~(rel_name : string) ~tuple_hash =
- let* () = self#assert_live "retract_tuple" in
- let* () = NT.retract_tuple ~branch_name:name ~mg_name:mg ~rel_name tuple_hash in
- self#sync_tip (); Ok ()
-
- (* Applies a Transition delta from a sublanguage executor. Each entry
- replaces the named mg in the cache, then the tip is re-read. *)
- method apply_delta (delta : (string * Management.Multigroup.multigroup) list) =
- List.iter (fun (mg_name, mg_val) -> Hashtbl.replace mgs mg_name mg_val) delta;
- self#sync_tip ()
-
- method close () = NT.close_branch bh
- end
-
- (* Default mg name seeded into an unborn branch so the session can write
- into something. Real catalog seeding (under "sakura") is the prelude's
- responsibility. *)
- let default_mg_name = "public"
-
- let open_branch claims branch_name =
- let* bh, _legacy_mg = NT.open_branch claims branch_name in
- let tip = match NT.branch_target_of_handle bh with Ok h -> h | Error _ -> "" in
- let* mg_entries = NT.list_branch_multigroups branch_name in
- let mgs =
- List.map
- (fun (mg_name, _mg_hash) ->
- (* For each bound mg, enumerate its relations from the kernel and
- rebuild the OCaml mirror. Schemas are not persisted in the
- snapshot codec — they are repopulated by DDL replay / catalog
- reads later. *)
- let rels =
- match NT.list_relations ~branch_name ~mg_name with Ok pairs -> pairs | Error _ -> []
- in
- let mg =
- List.fold_left
- (fun mg (rel_name, root) ->
- let rel =
- (new Relation.stored
- ~name:rel_name ~schema:[] ~constraints:None
- ~cardinality:Conventions.Cardinality.AlephZero
- ~lineage:(Some (Relation.Lineage.Base rel_name))
- ~provenance:(Some (Relation.Provenance.base ~relation:rel_name ~attributes:[]))
- ~membership_criteria:(fun _ -> true) )
- #set_tree_pointer
- (Some root)
- in
- mg#add_relation (rel :> Relation.relation) )
- (new Management.Multigroup.multigroup ~name:mg_name)
- rels
- in
- mg_name, mg )
- mg_entries
- in
- let mgs =
- if mgs = [] then [default_mg_name, new Management.Multigroup.multigroup ~name:default_mg_name]
- else mgs
- in
- Ok (new branch ~init_bh:bh ~init_name:branch_name ~init_tip:tip ~init_mgs:mgs ~init_mode:Live)
-
- let open_snapshot claims ~branch_name ~snapshot_hash =
- let* bh, mg = NT.open_snapshot claims branch_name snapshot_hash in
- Ok
- (new branch
- ~init_bh:bh ~init_name:branch_name ~init_tip:snapshot_hash
- ~init_mgs:[mg#name, mg]
- ~init_mode:(Detached snapshot_hash) )
-end
diff --git a/lib/constraint.ml b/lib/constraint.ml
deleted file mode 100644
index f657b00..0000000
--- a/lib/constraint.ml
+++ /dev/null
@@ -1,601 +0,0 @@
-(** Constraint system for relational membership criteria.
-
- A relation's intension includes constraints that refine the space of
- admissible tuples. Since constraints are themselves relations, checking a
- constraint = checking membership in that constraint-relation.
-
- Negation requires an explicit universe relation name, forcing closed-world
- reasoning in first-order logic. *)
-
-(* TODO: lt/lte/gt/gte/eq/neq/between at the bottom reference target names
- like "less_than" that don't match the prelude relation names
- (e.g. "natural_natural_less_than"). These constructors are currently dead
- code and will fail at runtime if used. *)
-
-type relation_name = string
-type attr_name = string
-type binding_expr = Var of attr_name | Const of Conventions.AbstractValue.t
-
-module BindingMap = Map.Make (String)
-module PolarityMap = Map.Make (String)
-module StringSet = Set.Make (String)
-module FingerTree = BatFingerTree
-
-type binding = binding_expr BindingMap.t
-
-type t =
- | MemberOf of {target: relation_name; binding: binding}
- | Not of {body: t; universe: relation_name}
- | And of t list
- | Or of t list
- | Exists of {variable: attr_name; quantifier: relation_name; body: t}
- | Forall of {variable: attr_name; quantifier: relation_name; body: t}
- | Eq of {left: binding_expr; right: binding_expr}
-
-type diagnostic =
- | MembershipFailed of
- {target: string; bound_values: (attr_name * Conventions.AbstractValue.t) list}
- | RelationNotFound of string
- | UnboundedQuantifier of {variable: attr_name; quantifier: relation_name}
- | ConstraintFailures of (string * diagnostic) list
-
-let vars_in (c : t) : attr_name list =
- let add_from_binding set binding =
- BindingMap.fold
- (fun _ expr acc -> match expr with Var v -> StringSet.add v acc | Const _ -> acc)
- binding set
- in
- let rec loop set worklist =
- match FingerTree.front worklist with
- | None -> set
- | Some (rest, node) -> (
- match node with
- | MemberOf {binding; _} -> loop (add_from_binding set binding) rest
- | Not {body; _} -> loop set (FingerTree.cons rest body)
- | And cs | Or cs ->
- let next = FingerTree.append (FingerTree.of_list cs) rest in
- loop set next
- | Exists {variable; body; _} | Forall {variable; body; _} ->
- loop (StringSet.add variable set) (FingerTree.cons rest body)
- | Eq {left; right} ->
- let add_expr acc = function Var v -> StringSet.add v acc | Const _ -> acc in
- loop (add_expr (add_expr set left) right) rest )
- in
- loop StringSet.empty (FingerTree.singleton c) |> StringSet.elements
-
-let rename_vars (renames : (attr_name * attr_name) list) : t -> t =
- let rename_map = BindingMap.of_seq (List.to_seq renames) in
- let rename_name name =
- match BindingMap.find_opt name rename_map with Some n -> n | None -> name
- in
- let rec go = function
- | MemberOf {target; binding} ->
- let binding' =
- BindingMap.fold
- (fun k expr acc ->
- let k' = rename_name k in
- let expr' = match expr with Var v -> Var (rename_name v) | Const _ -> expr in
- BindingMap.add k' expr' acc )
- binding BindingMap.empty
- in
- MemberOf {target; binding= binding'}
- | Not {body; universe} -> Not {body= go body; universe}
- | And cs -> And (List.map go cs)
- | Or cs -> Or (List.map go cs)
- | Exists {variable; quantifier; body} ->
- let variable' = rename_name variable in
- Exists {variable= variable'; quantifier; body= go body}
- | Forall {variable; quantifier; body} ->
- let variable' = rename_name variable in
- Forall {variable= variable'; quantifier; body= go body}
- | Eq {left; right} ->
- let rename_expr = function Var v -> Var (rename_name v) | Const _ as e -> e in
- Eq {left= rename_expr left; right= rename_expr right}
- in
- go
-
-(** Drop constraints referencing attributes not in the given set. Returns [None]
- if the constraint cannot be kept. *)
-let rec filter_by_attrs (attrs : attr_name list) (c : t) : t option =
- let all_present c = List.for_all (fun v -> List.mem v attrs) (vars_in c) in
- match c with
- | MemberOf _ -> if all_present c then Some c else None
- | Not {body; universe} -> (
- match filter_by_attrs attrs body with
- | Some body' -> Some (Not {body= body'; universe})
- | None -> None )
- | And cs ->
- let kept = List.filter_map (filter_by_attrs attrs) cs in
- if kept = [] then None else Some (And kept)
- | Or cs ->
- (* All branches must survive for Or to remain sound *)
- let kept = List.filter_map (filter_by_attrs attrs) cs in
- if List.length kept = List.length cs then Some (Or kept) else None
- | Exists {variable; quantifier; body} -> (
- match filter_by_attrs (variable :: attrs) body with
- | Some body' -> Some (Exists {variable; quantifier; body= body'})
- | None -> None )
- | Forall {variable; quantifier; body} -> (
- match filter_by_attrs (variable :: attrs) body with
- | Some body' -> Some (Forall {variable; quantifier; body= body'})
- | None -> None )
- | Eq _ -> if all_present c then Some c else None
-
-let merge (cs1 : (string * t) list) (cs2 : (string * t) list) : (string * t) list =
- let combined = cs1 @ cs2 in
- let tbl = Hashtbl.create 16 in
- List.iter
- (fun (name, c) ->
- match Hashtbl.find_opt tbl name with
- | None -> Hashtbl.replace tbl name [c]
- | Some cs -> Hashtbl.replace tbl name (c :: cs) )
- combined;
- Hashtbl.fold
- (fun name cs acc ->
- let merged = match cs with [c] -> c | _ -> And cs in
- (name, merged) :: acc )
- tbl []
-
-let member_of ~target ~binding = MemberOf {target; binding}
-let not_ ~universe body = Not {body; universe}
-let and_ cs = match cs with [c] -> c | _ -> And cs
-let or_ cs = match cs with [c] -> c | _ -> Or cs
-let exists ~variable ~quantifier body = Exists {variable; quantifier; body}
-let forall ~variable ~quantifier body = Forall {variable; quantifier; body}
-
-type eval_context =
- { check_membership: relation_name -> (attr_name * Conventions.AbstractValue.t) list -> bool;
- iterate_finite: relation_name -> (attr_name * Conventions.AbstractValue.t) list list option }
-
-let bind (b : binding) (tuple : Tuple.materialized) : (attr_name * Conventions.AbstractValue.t) list
- =
- BindingMap.fold
- (fun target_attr expr acc ->
- let value =
- match expr with
- | Const v -> Some v
- | Var src_attr -> (
- match Tuple.AttributeMap.find_opt src_attr tuple.attributes with
- | Some attr -> Some attr.Attribute.value
- | None -> None )
- in
- match value with Some v -> (target_attr, v) :: acc | None -> acc )
- b []
-
-let rec evaluate (ctx : eval_context) (tuple : Tuple.materialized) (c : t) :
- (bool, diagnostic) result =
- match c with
- | MemberOf {target; binding} ->
- let bound_values = bind binding tuple in
- if ctx.check_membership target bound_values then Ok true
- else Error (MembershipFailed {target; bound_values})
- | Not {body; universe= _} -> (
- (* The universe is a declarative annotation for closed-world reasoning.
- At runtime we negate the body; the universe enforces logical soundness
- at the schema level, not as a runtime tuple-existence check. *)
- match evaluate ctx tuple body with
- | Ok true -> Ok false
- | Ok false -> Ok true
- | Error (MembershipFailed _) -> Ok true
- | Error d -> Error d )
- | And cs -> evaluate_and ctx tuple cs
- | Or cs -> evaluate_or ctx tuple cs
- | Eq {left; right} -> (
- let resolve = function
- | Const v -> Some v
- | Var a -> (
- match Tuple.AttributeMap.find_opt a tuple.attributes with
- | Some attr -> Some attr.Attribute.value
- | None -> None )
- in
- match resolve left, resolve right with Some l, Some r -> Ok (l = r) | _ -> Ok false )
- | Exists {variable; quantifier; body} -> (
- match ctx.iterate_finite quantifier with
- | None -> Error (UnboundedQuantifier {variable; quantifier})
- | Some rows ->
- let rec check = function
- | [] -> Ok false
- | row :: rest -> (
- let extended_tuple = extend_tuple tuple variable row in
- match evaluate ctx extended_tuple body with
- | Ok true -> Ok true
- | Ok false -> check rest
- | Error _ -> check rest )
- in
- check rows )
- | Forall {variable; quantifier; body} -> (
- match ctx.iterate_finite quantifier with
- | None -> Error (UnboundedQuantifier {variable; quantifier})
- | Some rows ->
- let rec check = function
- | [] -> Ok true
- | row :: rest -> (
- let extended_tuple = extend_tuple tuple variable row in
- match evaluate ctx extended_tuple body with
- | Ok true -> check rest
- | Ok false -> Ok false
- | Error (MembershipFailed _) -> Ok false
- | Error d -> Error d )
- in
- check rows )
-
-and evaluate_and ctx tuple = function
- | [] -> Ok true
- | c :: rest -> (
- match evaluate ctx tuple c with
- | Ok true -> evaluate_and ctx tuple rest
- | Ok false -> Ok false
- | Error d -> Error d )
-
-and evaluate_or ctx tuple = function
- | [] -> Ok false
- | c :: rest -> (
- match evaluate ctx tuple c with
- | Ok true -> Ok true
- | Ok false -> evaluate_or ctx tuple rest
- | Error _ -> evaluate_or ctx tuple rest )
-
-and extend_tuple (tuple : Tuple.materialized) (variable : attr_name)
- (row : (attr_name * Conventions.AbstractValue.t) list) : Tuple.materialized =
- (* Quantifier attributes are namespaced by the variable name (for example "d.dept_id")
- so they cannot silently overwrite same-named attributes from the base tuple
- or from other quantifiers. Without such namespacing, a constraint like
- Exists d in Department, MemberOf Department (dept_id = Var "dept_id")
- would potentially overwrite the base tuple's dept_id with the Department row's dept_id,
- causing Var "dept_id" to resolve to the wrong value and accept invalid inserts.
- Constraints reference quantifier attributes as Var "variable.attr"
- (for example Var "d.dept_id") and base tuple attributes as Var "attr" (like Var "dept_id").
- This convention is the prerequisite for universal variable substitution
- (see docs/incremental_constraint_checking.org, specifically Technique 2).
- A better long-term solution would attach provenance metadata directly
- to each attribute rather than relying on name conventions, but we don't have that yet. *)
- let extra_attrs =
- List.fold_left
- (fun acc (k, v) -> Tuple.AttributeMap.add (variable ^ "." ^ k) {Attribute.value= v} acc)
- tuple.attributes row
- in
- {tuple with attributes= extra_attrs}
-
-(* TODO: Sometimes it's more efficient and sufficient to simply halt at the first constraint violated. However, it's also important to be able to adjudicate which constraints failed on the tuple materialization. For that reason, we should likely return a lazy stream that computes the constraints on demand. *)
-let evaluate_named (ctx : eval_context) (tuple : Tuple.materialized) (named : (string * t) list) :
- (bool, diagnostic) result =
- let failures =
- List.filter_map
- (fun (name, c) ->
- match evaluate ctx tuple c with
- | Ok true -> None
- | Ok false -> Some (name, MembershipFailed {target= name; bound_values= []})
- | Error d -> Some (name, d) )
- named
- in
- match failures with [] -> Ok true | fs -> Error (ConstraintFailures fs)
-
-(** Fast-path evaluator: halts at the first non-passing constraint. Use in
- cascade and deferred checking where a single violation suffices. *)
-let evaluate_first_failure (ctx : eval_context) (tuple : Tuple.materialized)
- (named : (string * t) list) : (bool, diagnostic) result =
- let rec loop = function
- | [] -> Ok true
- | (_name, c) :: rest -> ( match evaluate ctx tuple c with Ok true -> loop rest | r -> r )
- in
- loop named
-
-(** Polarity analysis: determines whether each relation name appears in a
- positive (must-exist) or negative (must-not-exist) position within a
- constraint tree. Used for cascade checking: when a tuple is deleted, only
- relations with Positive or Both polarity need re-validation. *)
-
-type polarity = Positive | Negative | Both
-type polarity_index = polarity PolarityMap.t
-
-let merge_polarity a b =
- match a, b with Positive, Positive -> Positive | Negative, Negative -> Negative | _ -> Both
-
-let flip_polarity = function Positive -> Negative | Negative -> Positive | Both -> Both
-
-let polarity_of ?(neg = false) (c : t) : polarity_index =
- let with_neg is_neg pol = if is_neg then flip_polarity pol else pol in
- let add_pol acc name pol =
- match PolarityMap.find_opt name acc with
- | None -> PolarityMap.add name pol acc
- | Some prev -> PolarityMap.add name (merge_polarity prev pol) acc
- in
- let rec loop acc worklist =
- match FingerTree.front worklist with
- | None -> acc
- | Some (rest, (is_neg, node)) -> (
- match node with
- | MemberOf {target; _} -> loop (add_pol acc target (with_neg is_neg Positive)) rest
- | Not {body; _} -> loop acc (FingerTree.cons rest (not is_neg, body))
- | And cs | Or cs ->
- let children = List.map (fun child -> is_neg, child) cs |> FingerTree.of_list in
- let next = FingerTree.append children rest in
- loop acc next
- | Exists {quantifier; body; _} ->
- let acc' = add_pol acc quantifier (with_neg is_neg Positive) in
- loop acc' (FingerTree.cons rest (is_neg, body))
- | Forall {quantifier; body; _} ->
- let acc' = add_pol acc quantifier (with_neg is_neg Negative) in
- loop acc' (FingerTree.cons rest (is_neg, body))
- | Eq _ -> loop acc rest )
- in
- loop PolarityMap.empty (FingerTree.singleton (neg, c))
-
-let polarity_find name (pols : polarity_index) = PolarityMap.find_opt name pols
-
-(** Constraint timing: immediate (checked on every mutation) or deferred
- (checked at transaction commit). *)
-type timing = Immediate | Deferred
-
-type substitute_mode = SubstituteGo | SubstituteApply of Conventions.AbstractValue.t BindingMap.t
-
-type substitute_instr =
- | Visit of substitute_mode * t
- | BuildNot of relation_name
- | BuildAnd of int
- | BuildOr of int
- | BuildExists of attr_name * relation_name
- | BuildForall of attr_name * relation_name
-
-(** Given a constraint, a deleted relation name [dep_rel], and the deleted
- tuple's attributes, return a filter: [(attr_name, value)] pairs that narrow
- which constrained-relation tuples could be affected.
-
- For a Var binding like [dept_id = Var "dept_id"] targeting [dep_rel], the
- deleted tuple's [dept_id] value becomes the filter: only constrained tuples
- with that exact [dept_id] need re-checking.
-
- Returns [] if no narrowing is possible (Const bindings, unrelated rel). *)
-let focused_filter (c : t) (dep_rel : relation_name)
- (deleted : (attr_name * Conventions.AbstractValue.t) list) :
- (attr_name * Conventions.AbstractValue.t) list =
- let add_from_binding acc binding =
- BindingMap.fold
- (fun _target_attr expr acc ->
- match expr with
- | Var src_attr -> (
- match List.assoc_opt src_attr deleted with Some v -> (src_attr, v) :: acc | None -> acc )
- | Const _ -> acc )
- binding acc
- in
- let rec loop acc worklist =
- match FingerTree.front worklist with
- | None -> acc
- | Some (rest, node) -> (
- match node with
- | MemberOf {target; binding} when target = dep_rel -> loop (add_from_binding acc binding) rest
- | MemberOf _ -> loop acc rest
- | Not {body; _} | Exists {body; _} | Forall {body; _} -> loop acc (FingerTree.cons rest body)
- | And cs | Or cs ->
- let next = FingerTree.append (FingerTree.of_list cs) rest in
- loop acc next
- | Eq _ -> loop acc rest )
- in
- loop [] (FingerTree.singleton c)
-
-(** Extract Const binding values from a constraint for a given [dep_rel].
-
- These are fixed-value preconditions: if the deleted tuple doesn't have these
- exact values, the constraint cannot be violated by the deletion. The cascade
- checker uses this to bail out early. *)
-let trigger_constants (c : t) (dep_rel : relation_name) :
- (attr_name * Conventions.AbstractValue.t) list =
- let add_from_binding acc binding =
- BindingMap.fold
- (fun target_attr expr acc ->
- match expr with Const v -> (target_attr, v) :: acc | Var _ -> acc )
- binding acc
- in
- let rec loop acc worklist =
- match FingerTree.front worklist with
- | None -> acc
- | Some (rest, node) -> (
- match node with
- | MemberOf {target; binding} when target = dep_rel -> loop (add_from_binding acc binding) rest
- | MemberOf _ -> loop acc rest
- | Not {body; _} | Exists {body; _} | Forall {body; _} -> loop acc (FingerTree.cons rest body)
- | And cs | Or cs ->
- let next = FingerTree.append (FingerTree.of_list cs) rest in
- loop acc next
- | Eq _ -> loop acc rest )
- in
- loop [] (FingerTree.singleton c)
-
-(** Substitute transition tuple values into a constraint for universal variable
- substitution. When [dep_rel] is being mutated (deleted from or inserted
- into), any [Exists] or [Forall] that quantifies over [dep_rel] has its body
- rewritten: occurrences of [Var "variable.attr"] are replaced by
- [Const value] using the transition tuple's attribute values.
-
- The convention that quantifier attributes are namespaced as [variable.attr]
- (established by [extend_tuple]) means base tuple [Var] references like
- [Var "dept_id"] are never substituted, only [Var "d.dept_id"] would match a
- quantifier variable [d] over a deleted [Department] row.
-
- This transforms the recheck from a full relation evaluation into a targeted
- expression that tests only the rows affected by the transition tuple. See
- Technique 2 in docs/incremental_constraint_checking.org. *)
-let substitute_transition (c : t) (dep_rel : relation_name)
- (transition : (attr_name * Conventions.AbstractValue.t) list) : t =
- let namespaced_subs variable =
- List.fold_left
- (fun acc (a, v) -> BindingMap.add (variable ^ "." ^ a) v acc)
- BindingMap.empty transition
- in
- let enqueue_visit_then_build visit build rest =
- FingerTree.cons (FingerTree.cons rest build) visit
- in
- let enqueue_children mode cs build_of_count rest =
- let prefix, count =
- List.fold_left
- (fun (acc, n) child -> FingerTree.snoc acc (Visit (mode, child)), n + 1)
- (FingerTree.empty, 0) cs
- in
- let prefix = FingerTree.snoc prefix (build_of_count count) in
- FingerTree.append prefix rest
- in
- let apply_subs subs binding =
- BindingMap.map
- (function
- | Var v -> (
- match BindingMap.find_opt v subs with Some value -> Const value | None -> Var v )
- | Const _ as expr -> expr )
- binding
- in
- let rec pop_n n vals acc =
- if n = 0 then acc, vals
- else match vals with [] -> acc, [] | v :: rest -> pop_n (n - 1) rest (v :: acc)
- in
- let rec loop instrs vals =
- match FingerTree.front instrs with
- | None -> ( match vals with [result] -> result | _ -> c )
- | Some (rest, instr) -> (
- match instr with
- | Visit (mode, node) -> (
- match node with
- | MemberOf {target; binding} ->
- let binding' =
- match mode with
- | SubstituteGo -> binding
- | SubstituteApply subs -> apply_subs subs binding
- in
- loop rest (MemberOf {target; binding= binding'} :: vals)
- | Not {body; universe} ->
- loop (enqueue_visit_then_build (Visit (mode, body)) (BuildNot universe) rest) vals
- | And cs ->
- let instrs' = enqueue_children mode cs (fun n -> BuildAnd n) rest in
- loop instrs' vals
- | Or cs ->
- let instrs' = enqueue_children mode cs (fun n -> BuildOr n) rest in
- loop instrs' vals
- | Exists {variable; quantifier; body} ->
- let body_mode =
- match mode with
- | SubstituteApply subs -> SubstituteApply subs
- | SubstituteGo ->
- if quantifier = dep_rel then SubstituteApply (namespaced_subs variable)
- else SubstituteGo
- in
- loop
- (enqueue_visit_then_build
- (Visit (body_mode, body))
- (BuildExists (variable, quantifier))
- rest )
- vals
- | Forall {variable; quantifier; body} ->
- let body_mode =
- match mode with
- | SubstituteApply subs -> SubstituteApply subs
- | SubstituteGo ->
- if quantifier = dep_rel then SubstituteApply (namespaced_subs variable)
- else SubstituteGo
- in
- loop
- (enqueue_visit_then_build
- (Visit (body_mode, body))
- (BuildForall (variable, quantifier))
- rest )
- vals
- | Eq {left; right} ->
- let subst_expr subs = function
- | Var v -> (
- match BindingMap.find_opt v subs with Some v' -> Const v' | None -> Var v )
- | Const _ as e -> e
- in
- let left', right' =
- match mode with
- | SubstituteGo -> left, right
- | SubstituteApply subs -> subst_expr subs left, subst_expr subs right
- in
- loop rest (Eq {left= left'; right= right'} :: vals) )
- | BuildNot universe -> (
- match vals with
- | body :: vals' -> loop rest (Not {body; universe} :: vals')
- | [] -> loop rest vals )
- | BuildAnd n ->
- let children, vals' = pop_n n vals [] in
- loop rest (And children :: vals')
- | BuildOr n ->
- let children, vals' = pop_n n vals [] in
- loop rest (Or children :: vals')
- | BuildExists (variable, quantifier) -> (
- match vals with
- | body :: vals' -> loop rest (Exists {variable; quantifier; body} :: vals')
- | [] -> loop rest vals )
- | BuildForall (variable, quantifier) -> (
- match vals with
- | body :: vals' -> loop rest (Forall {variable; quantifier; body} :: vals')
- | [] -> loop rest vals ) )
- in
- loop (FingerTree.singleton (Visit (SubstituteGo, c))) []
-
-let make_comparison_binding ~left ~right =
- BindingMap.empty |> BindingMap.add "left" left |> BindingMap.add "right" right
-
-let lt ~left ~right = MemberOf {target= "less_than"; binding= make_comparison_binding ~left ~right}
-
-let lte ~left ~right =
- MemberOf {target= "less_than_or_equal"; binding= make_comparison_binding ~left ~right}
-
-let gt ~left ~right =
- MemberOf {target= "greater_than"; binding= make_comparison_binding ~left ~right}
-
-let gte ~left ~right =
- MemberOf {target= "greater_than_or_equal"; binding= make_comparison_binding ~left ~right}
-
-let eq ~left ~right = Eq {left; right}
-let neq ~left ~right = Not {body= Eq {left; right}; universe= ""}
-
-let between ~value ~low ~high =
- And
- [ MemberOf
- {target= "greater_than_or_equal"; binding= make_comparison_binding ~left:value ~right:low};
- MemberOf
- {target= "less_than_or_equal"; binding= make_comparison_binding ~left:value ~right:high} ]
-
-(** Build membership criteria from schema (validates type membership). Returns a
- function that takes a tree-lookup function and a tuple, checking schema
- conformance and tree membership at call time. *)
-let build_membership_criteria ~_name ~schema : (*(string -> Merkle.t option) ->*) Tuple.t -> bool =
- let value_conforms_to_domain domain_name (value : Conventions.AbstractValue.t) =
- match domain_name with
- | "integer" -> Obj.is_int value
- | "natural" -> Obj.is_int value && (Obj.obj value : int) >= 0
- | "string" -> Obj.tag value = Obj.string_tag
- | _ ->
- (* Unknown domain: could be a relation-typed attribute (nested tuple)
- or a user-defined domain. Accept for now; full validation would
- require looking up the target relation's schema. *)
- true
- in
- let n_expected = List.length schema in
- (* fun tree_of tuple -> *)
- fun tuple ->
- match tuple with
- | Tuple.NonMaterialized _nm ->
- (* begin match tree_of name with
- | None -> false
- | Some t ->
- Merkle.member nm.hash t
- && Tuple.AttributeMap.cardinal nm.attributes = n_expected
- && List.for_all
- (fun (attr_name, _) ->
- Tuple.AttributeMap.mem attr_name nm.attributes)
- schema
- end *)
- false
- | Tuple.Materialized m ->
- Tuple.AttributeMap.cardinal m.attributes = n_expected
- && List.for_all
- (fun (attr_name, domain_name) ->
- match Tuple.AttributeMap.find_opt attr_name m.attributes with
- | None -> false
- | Some attr -> value_conforms_to_domain domain_name attr.Attribute.value )
- schema
-
-(** Mutation direction for cascade constraint checking *)
-type mutation = Insert | Delete
-
-(** Context for a single tuple mutation, used by cascade checking *)
-type mutation_context =
- {target_relation: string; transition: (string * Conventions.AbstractValue.t) list; kind: mutation}
diff --git a/lib/conventions.ml b/lib/conventions.ml
deleted file mode 100644
index 70f33cf..0000000
--- a/lib/conventions.ml
+++ /dev/null
@@ -1,55 +0,0 @@
-module Hash = struct
- type t = string
-
- let hash_text text = Sha256.to_hex (Sha256.string text)
- let compare = String.compare
- let sexp_of_t = Sexplib.Std.sexp_of_string
-end
-
-module Name = struct
- type t = string
-
- let sexp_of_t = Sexplib.Std.sexp_of_string
-end
-
-module Cardinality = struct
- open Sexplib.Std
-
- type t = Finite of int | ConstrainedFinite | AlephZero | Continuum [@@deriving sexp]
-end
-
-module Purity = struct
- type t = Pure | IO [@@deriving sexp]
-end
-
-module AbstractValue = struct
- type t = Obj.t
- type value_type = Int | String | Float | Opaque
-
- let hash (elem : t) = Sha256.to_hex (Sha256.string (Bytes.to_string (Marshal.to_bytes elem [])))
-
- let type_of (elem : t) : value_type =
- let tag = Obj.tag elem in
- if Obj.is_int elem then Int
- else if tag = Obj.string_tag then String
- else if tag = Obj.double_tag then Float
- else Opaque
-
- let sexp_of_t (v : t) =
- let open Sexplib.Sexp in
- match type_of v with
- | Int -> Atom (string_of_int (Obj.obj v : int))
- | String -> Atom (Obj.obj v : string)
- | Float ->
- let f = (Obj.obj v : float) in
- if Float.is_nan f || Float.is_infinite f then Atom "nan" else Atom (string_of_float f)
- | Opaque -> Atom "<opaque>"
-
- let equal a b =
- match type_of a, type_of b with
- | Int, Int -> (Obj.obj a : int) = (Obj.obj b : int)
- | String, String -> (Obj.obj a : string) = (Obj.obj b : string)
- | Float, Float -> (Obj.obj a : float) = (Obj.obj b : float)
- | Opaque, Opaque -> false
- | _, _ -> false
-end
diff --git a/lib/ddl/ast.ml b/lib/ddl/ast.ml
deleted file mode 100644
index 86af755..0000000
--- a/lib/ddl/ast.ml
+++ /dev/null
@@ -1,12 +0,0 @@
-open Sexplib.Std
-
-type cardinality_spec = Finite of int | AlephZero | Continuum | ConstrainedFinite
-[@@deriving sexp]
-
-type statement =
- | CreateMultigroup of string
- | CreateRelation of {name: string; schema: (string * string) list}
- | RetractRelation of string
- | ClearRelation of string
- | RegisterDomain of {name: string; cardinality: cardinality_spec}
-[@@deriving sexp]
diff --git a/lib/ddl/executor.ml b/lib/ddl/executor.ml
deleted file mode 100644
index c16ff1f..0000000
--- a/lib/ddl/executor.ml
+++ /dev/null
@@ -1,81 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Error = struct
- open Condition
-
- (* TODO: more structure *)
- let relation_not_found name =
- condition "relation-not-found" "Relation not found" ("name" |=| of_string name)
-
- let multigroup_not_found name =
- condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name)
- end
-
- let ( let* ) = Result.bind
- let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s
-
- let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) :
- (Management.Multigroup.multigroup, Condition.t) result =
- match ctx.branch#mg_of mg_name with
- | Some mg -> Ok mg
- | None -> Error (Error.multigroup_not_found mg_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
- | Ast.ConstrainedFinite -> Conventions.Cardinality.ConstrainedFinite
-
- (* Every relation-touching statement names exactly one mg via its FQN
- prefix. The executor parses the FQN, resolves the mg in the branch
- cache, advances it through NT, and returns a single-element delta. *)
- let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) :
- (Sublanguage_types.transition_delta * string, Condition.t) result =
- let bh = ctx.write_handle in
- let branch_name = ctx.branch#name in
- match stmt with
- | Ast.CreateMultigroup name -> (
- ctx.branch#add_multigroup ~name;
- match ctx.branch#mg_of name with
- | Some mg -> Ok ([name, mg], "Multigroup created: " ^ name)
- | None -> Error (Error.multigroup_not_found name) )
- | Ast.CreateRelation {name; schema= schema_pairs} ->
- let* fqn = parse_fqn name in
- let* mg = lookup_mg ctx fqn.mg in
- let schema =
- List.fold_left (fun s (attr, dom) -> Schema.add attr dom s) Schema.empty schema_pairs
- in
- let* _bh, new_mg = NT.create_relation bh mg ~branch_name ~name:fqn.name ~schema in
- ctx.branch#set_mg ~name:fqn.mg new_mg;
- Ok ([fqn.mg, new_mg], "Relation created: " ^ name)
- | Ast.RetractRelation name ->
- let* fqn = parse_fqn name in
- let* mg = lookup_mg ctx fqn.mg in
- let* _bh, new_mg = NT.retract_relation bh mg ~name:fqn.name in
- ctx.branch#set_mg ~name:fqn.mg new_mg;
- Ok ([fqn.mg, new_mg], "Relation retracted: " ^ name)
- | Ast.ClearRelation name -> (
- let* fqn = parse_fqn name in
- let* mg = lookup_mg ctx fqn.mg in
- match mg#get_relation fqn.name with
- | None -> Error (Error.relation_not_found name)
- | Some rel ->
- let* _bh, new_mg =
- NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg (rel :> Relation.relation)
- in
- ctx.branch#set_mg ~name:fqn.mg new_mg;
- Ok ([fqn.mg, new_mg], "Relation cleared: " ^ name) )
- | Ast.RegisterDomain {name; cardinality} ->
- let* fqn = parse_fqn name in
- let* mg = lookup_mg ctx fqn.mg in
- let domain : Relation.domain =
- new Relation.domain
- ~name:fqn.name
- ~generator:(fun _ -> Generator.Error "not enumerable via DDL")
- ~membership_criteria:(fun _ -> true)
- ~cardinality:(convert_cardinality cardinality) ~schema:Schema.empty ~provenance:None
- ~lineage:None ~constraints:None
- in
- let* _bh, new_mg = NT.register_domain bh mg domain in
- ctx.branch#set_mg ~name:fqn.mg new_mg;
- Ok ([fqn.mg, new_mg], "Domain registered: " ^ name)
-end
diff --git a/lib/ddl/parser.ml b/lib/ddl/parser.ml
deleted file mode 100644
index 094b0fd..0000000
--- a/lib/ddl/parser.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-module Error = struct
- open Condition
-
- let parse_error msg = condition "parse-error" msg empty
-end
-
-let of_sexp sexp =
- match Ast.statement_of_sexp sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-let of_string s =
- match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-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
deleted file mode 100644
index da3ba3a..0000000
--- a/lib/ddl/sublanguage.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Exec = Executor.Make (NT)
-
- type configuration = unit
- type ast = Ast.statement
-
- let name = "ddl"
- let parse _ = Ok ()
- let parse_sexp sexp = Parser.of_sexp sexp
-
- let execute ctx ast =
- match Exec.execute ctx ast with
- | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta)
- | Error e -> Error e
-end
diff --git a/lib/dml/ast.ml b/lib/dml/ast.ml
deleted file mode 100644
index e34adb9..0000000
--- a/lib/dml/ast.ml
+++ /dev/null
@@ -1,19 +0,0 @@
-open Sexplib.Std
-
-type attr_value = string * Drl.Ast.value [@@deriving sexp]
-
-type statement =
- | InsertTuple of {relation: string; attributes: attr_value list}
- | InsertTuples of {relation: string; tuples: attr_value list list}
- | DeleteTuple of {relation: string; attributes: attr_value list}
- | Assign of {target: string; body: Drl.Ast.query}
- | InsertFrom of {target: string; source: Drl.Ast.query}
- | DeleteWhere of {target: string; predicate: Drl.Ast.query}
- (** Binds an unqualified name to a session-scoped ephemeral relation. The
- body is recomputed on each scan and never materialized; the binding
- lives until [DropDefine] or a session close. In contrast, [Assign]
- drains the body into an existing stored relation. *)
- | Define of {target: string; body: Drl.Ast.query}
- (** Drops a [Define] binding, releasing its session-ownership pin. *)
- | DropDefine of {target: string}
-[@@deriving sexp]
diff --git a/lib/dml/executor.ml b/lib/dml/executor.ml
deleted file mode 100644
index f034f4a..0000000
--- a/lib/dml/executor.ml
+++ /dev/null
@@ -1,228 +0,0 @@
-module Make (NT : Nt.S) = struct
- module DrlExec = Drl.Executor.Make (NT)
-
- module Error = struct
- open Condition
-
- (* TODO: more structure *)
- let parse_error msg = condition "parse-error" msg empty
-
- let relation_not_found name =
- condition "relation-not-found" "Relation not found" ("name" |=| of_string name)
-
- let multigroup_not_found name =
- condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name)
- end
-
- let ( let* ) = Result.bind
- let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s
-
- let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) :
- (Management.Multigroup.multigroup, Condition.t) result =
- match ctx.branch#mg_of mg_name with
- | Some mg -> Ok mg
- | None -> Error (Error.multigroup_not_found mg_name)
-
- let get_rel (ctx : Sublanguage_context.t) (fqn : Qualified_name.t) =
- let* mg = lookup_mg ctx fqn.mg in
- match NT.get_relation mg fqn.name with
- | Some r -> Ok r
- | None -> Error (Error.relation_not_found (Qualified_name.to_string fqn))
-
- let retarget target (t : Tuple.materialized) = {t with Tuple.relation= target}
-
- let 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
- in
- {Tuple.relation; attributes= attr_map}
-
- (* Drain all tuples from a DRL query using ctx.resolve for path resolution.
- Cross-multigroup reads work transparently here. *)
- let drain_query (ctx : Sublanguage_context.t) query =
- let* plan = DrlExec.compile ctx query in
- let* stream = NT.execute_query plan ~rel_name:"dml_drain" in
- let rec drain acc =
- match NT.stream_next stream with
- | Error _ -> List.rev acc
- | Ok None -> List.rev acc
- | Ok (Some t) -> drain (t :: acc)
- in
- let tuples = drain [] in
- ignore (NT.stream_close stream);
- Ok tuples
-
- (* Stored-relation paths referenced by a query, for ephemeral dependency
- pinning. A qualified leaf resolves through ctx; an unqualified one is a
- previously Defined session ephemeral (views compose). *)
- let rec base_dep_paths (ctx : Sublanguage_context.t) (q : Drl.Ast.query) : string list =
- match q with
- | Drl.Ast.Base name -> (
- match Qualified_name.try_parse name with
- | Ok fqn -> [ctx.resolve fqn]
- | Error _ -> [Sublanguage_context.ephemeral_path ctx name] )
- | Drl.Ast.Const _ -> []
- | Drl.Ast.Select (a, b)
- |Drl.Ast.Join (_, a, b)
- |Drl.Ast.Cartesian (a, b)
- |Drl.Ast.Union (a, b)
- |Drl.Ast.Diff (a, b) ->
- base_dep_paths ctx a @ base_dep_paths ctx b
- | Drl.Ast.Project (_, s) | Drl.Ast.Rename (_, s) | Drl.Ast.Take (_, s) -> base_dep_paths ctx s
-
- (* Schema of a query result, walked structurally from the base relations'
- schemas. Mirrors the operator semantics in docs/relational-algebra.org. *)
- let rec infer_schema (ctx : Sublanguage_context.t) (q : Drl.Ast.query) :
- (Schema.t, Condition.t) result =
- match q with
- | Drl.Ast.Base name -> (
- match Qualified_name.try_parse name with
- | Error _ ->
- (* Session ephemeral: RNT owns its schema; nothing to derive
- on the OCaml-side, so treated as contributing no attributes. *)
- Ok []
- | Ok fqn ->
- let* rel = get_rel ctx fqn in
- Ok rel#schema )
- | Drl.Ast.Const attrs -> Ok (List.map (fun (n, _) -> n, "abstract") attrs)
- | Drl.Ast.Select (_, src) -> infer_schema ctx src
- | Drl.Ast.Join (_, l, r) | Drl.Ast.Cartesian (l, r) ->
- let* ls = infer_schema ctx l in
- let* rs = infer_schema ctx r in
- Ok (ls @ List.filter (fun (n, _) -> not (List.mem_assoc n ls)) rs)
- | Drl.Ast.Project (attrs, src) ->
- let* s = infer_schema ctx src in
- Ok (List.filter (fun (n, _) -> List.mem n attrs) s)
- | Drl.Ast.Rename (renames, src) ->
- let* s = infer_schema ctx src in
- Ok
- (List.map
- (fun (n, d) -> match List.assoc_opt n renames with Some n' -> n', d | None -> n, d)
- s )
- | Drl.Ast.Union (l, _) | Drl.Ast.Diff (l, _) -> infer_schema ctx l
- | Drl.Ast.Take (_, src) -> infer_schema ctx src
-
- let attr_val_eq a b = Stdlib.( = ) a.Attribute.value b.Attribute.value
-
- let tuple_matches_pred common (target_t : Tuple.materialized) (pred_t : Tuple.materialized) =
- List.for_all
- (fun attr ->
- match
- ( Tuple.AttributeMap.find_opt attr target_t.Tuple.attributes,
- Tuple.AttributeMap.find_opt attr pred_t.Tuple.attributes )
- with
- | Some a, Some b -> attr_val_eq a b
- | _ -> false )
- common
-
- let semijoin common target_tuples pred_tuples =
- List.filter (fun t -> List.exists (tuple_matches_pred common t) pred_tuples) target_tuples
-
- (* DML mutates tuples in a single mg per statement. Returns a
- single-element transition delta keyed by that mg's name. *)
- let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) :
- (Sublanguage_types.transition_delta, Condition.t) result =
- let bh = ctx.write_handle in
- let branch_name = ctx.branch#name in
- let after fqn =
- Result.bind (lookup_mg ctx fqn.Qualified_name.mg) (fun mg -> Ok [fqn.Qualified_name.mg, mg])
- in
- match stmt with
- | Ast.InsertTuple {relation; attributes} ->
- let* fqn = parse_fqn relation in
- let* rel = get_rel ctx fqn in
- let tuple = build_tuple ~relation:rel#name attributes in
- let* _ = NT.create_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple in
- after fqn
- | Ast.InsertTuples {relation; tuples} ->
- let* fqn = parse_fqn relation in
- let* rel = get_rel ctx fqn in
- let tuple_list = List.map (build_tuple ~relation:rel#name) tuples in
- let* _ = NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name tuple_list in
- after fqn
- | Ast.DeleteTuple {relation; attributes} ->
- let* fqn = parse_fqn relation in
- let* rel = get_rel ctx fqn in
- let tuple = build_tuple ~relation:rel#name attributes in
- let hash = Hashing.hash_tuple tuple in
- let* () = NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash in
- after fqn
- | Ast.Assign {target; body} ->
- let* fqn = parse_fqn target in
- let* mg = lookup_mg ctx fqn.mg in
- let* rel = get_rel ctx fqn in
- let* tuples = drain_query ctx body in
- let* _bh, new_mg =
- NT.clear_relation bh mg ~branch_name ~mg_name:fqn.mg (rel :> Relation.relation)
- in
- ctx.branch#set_mg ~name:fqn.mg new_mg;
- let* _ =
- NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name
- (List.map (retarget rel#name) tuples)
- in
- Ok [fqn.mg, new_mg]
- | Ast.InsertFrom {target; source} ->
- let* fqn = parse_fqn target in
- let* rel = get_rel ctx fqn in
- let* tuples = drain_query ctx source in
- let* _ =
- NT.create_tuples ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name
- (List.map (retarget rel#name) tuples)
- in
- after fqn
- | Ast.Define {target; body} ->
- let* () =
- if String.contains target ':' then
- Error
- (Error.parse_error ("Define target must be unqualified (session-scoped): " ^ target))
- else Ok ()
- in
- (* TODO: redefining an existing name isn't guarded. Right now we lean on
- Hashtbl.replace and whatever RNT does on collision. Pick replace or
- error and enforce it here. *)
- let* schema = infer_schema ctx body in
- (* TODO: every page drains the whole query and then filters down to the
- window, so paging costs O(total * pages) and reruns the VM plan each
- time. Push the offset/limit down or cache the result. *)
- let generator ~offset ~limit =
- match drain_query ctx body with
- | Error _ -> []
- | Ok tuples -> List.filteri (fun i _ -> i >= offset && i < offset + limit) tuples
- in
- let* _path =
- NT.register_ephemeral ~session:ctx.session_hash ~named:true ~name:target ~generator
- ~cardinality:Conventions.Cardinality.ConstrainedFinite
- ~identity:(Drl.Parser.to_string body) ~schema ~deps:(base_dep_paths ctx body)
- in
- Ok []
- | Ast.DropDefine {target} ->
- let* () = NT.drop_ephemeral ~session:ctx.session_hash ~name:target in
- Ok []
- | Ast.DeleteWhere {target; predicate} ->
- let* fqn = parse_fqn target in
- let* rel = get_rel ctx fqn in
- let* target_tuples = drain_query ctx (Drl.Ast.Base target) in
- let* pred_tuples = drain_query ctx predicate in
- let attr_names_of = function
- | [] -> []
- | t :: _ -> List.map fst (Tuple.AttributeMap.bindings t.Tuple.attributes)
- in
- let target_attrs = attr_names_of target_tuples in
- let pred_attrs = attr_names_of pred_tuples in
- let common = List.filter (fun n -> List.mem n pred_attrs) target_attrs in
- let to_delete = semijoin common target_tuples pred_tuples in
- let* () =
- List.fold_left
- (fun acc t ->
- let* () = acc in
- let hash = Hashing.hash_tuple (retarget rel#name t) in
- NT.retract_tuple ~branch_name ~mg_name:fqn.mg ~rel_name:rel#name hash )
- (Ok ()) to_delete
- in
- after fqn
-end
-
-module Memory = Make (Nt.Memory)
diff --git a/lib/dml/parser.ml b/lib/dml/parser.ml
deleted file mode 100644
index 094b0fd..0000000
--- a/lib/dml/parser.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-module Error = struct
- open Condition
-
- let parse_error msg = condition "parse-error" msg empty
-end
-
-let of_sexp sexp =
- match Ast.statement_of_sexp sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-let of_string s =
- match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-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
deleted file mode 100644
index 6e9d2c8..0000000
--- a/lib/dml/sublanguage.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Exec = Executor.Make (NT)
-
- type configuration = unit
- type ast = Ast.statement
-
- let name = "dml"
- let parse _ = Ok ()
- let parse_sexp sexp = Parser.of_sexp sexp
-
- let execute ctx ast =
- match Exec.execute ctx ast with
- | Ok delta -> Ok (Sublanguage_types.Transition delta)
- | Error e -> Error e
-end
diff --git a/lib/error.ml b/lib/error.ml
deleted file mode 100644
index 4f1cecd..0000000
--- a/lib/error.ml
+++ /dev/null
@@ -1,35 +0,0 @@
-(** Error types for manipulation operations *)
-type t =
- | RelationNotFound of string
- | RelationAlreadyExists of string
- | TupleNotFound of Conventions.Hash.t
- | DuplicateTuple of Conventions.Hash.t
- | ConstraintViolation of string
- | StorageError of string
- | UnrecognizedSublanguage of string
- | MalformedExpression of Sexplib.Sexp.t
- (* TODO: think of a better way to manage and serialize sublanguage errors *)
- | SublanguageError of Sexplib.Sexp.t
- | Conflict of {old_db: Management.Multigroup.multigroup; new_db: Management.Multigroup.multigroup}
- | SyntaxError of string
- | MultigroupNotFound of string
-
-let sexp_of_error e =
- let open Sexplib.Sexp in
- let error e ps = List (Atom e :: ps) in
- let ( <+> ) key value = List [Atom key; value] in
- match e with
- (* TODO: think of a subset of common attributes that every error should have (message, etc)? *)
- | RelationNotFound s -> error "relation-not-found" ["relation" <+> Atom s]
- | RelationAlreadyExists s -> error "relation-already-exists" ["relation" <+> Atom s]
- | TupleNotFound h -> error "tuple-not-found" ["hash" <+> Atom h]
- | DuplicateTuple h -> error "duplicate-tuple" ["hash" <+> Atom h]
- | ConstraintViolation s -> error "constraint-violation" ["message" <+> Atom s]
- | StorageError s -> error "storage-error" ["message" <+> Atom s]
- | UnrecognizedSublanguage s -> error "unrecognized-sublanguage" ["tag" <+> Atom s]
- | MalformedExpression s -> error "malformed-expression" ["expression" <+> s]
- | SublanguageError s -> error "sublanguage-error" ["error" <+> s]
- | SyntaxError s -> error "syntax-error" ["message" <+> Atom s]
- | MultigroupNotFound s -> error "multigroup-not-found" ["name" <+> Atom s]
- | Conflict {old_db; new_db} ->
- error "conflict" ["old" <+> Atom old_db#name; "new" <+> Atom new_db#name]
diff --git a/lib/hashing.ml b/lib/hashing.ml
deleted file mode 100644
index cc4bf10..0000000
--- a/lib/hashing.ml
+++ /dev/null
@@ -1,52 +0,0 @@
-(** 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:
- - Deduplication of tuples
- - Merkle tree construction for relations and databases
- - Time-travel queries (load any historical state by hash) *)
-
-(** Convert bytes to hex string (to avoid null bytes in hash input) *)
-let bytes_to_hex bytes =
- let len = Bytes.length bytes in
- let hex = Bytes.create (len * 2) in
- for i = 0 to len - 1 do
- let c = Bytes.get_uint8 bytes i in
- 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))
- done;
- Bytes.to_string hex
-
-(** 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) *)
-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
- in
- Conventions.Hash.hash_text content
-
-(** 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"
- in
- Conventions.Hash.hash_text (name ^ "|" ^ schema_str ^ "|" ^ tree_hash) *)
diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml
deleted file mode 100644
index 1a5b096..0000000
--- a/lib/icl/ast.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-open Sexplib.Std
-
-type binding_expr = Var of string | Const of Drl.Ast.value (** reuse DRL value for literals *)
-[@@deriving sexp]
-
-type constraint_body =
- | MemberOf of {target: string; binding: (string * binding_expr) list}
- | Not of {body: constraint_body; universe: string}
- | 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}
-[@@deriving sexp]
-
-type statement =
- | RegisterConstraint of {constraint_name: string; relation_name: string; body: constraint_body}
-[@@deriving sexp]
diff --git a/lib/icl/executor.ml b/lib/icl/executor.ml
deleted file mode 100644
index dd0a1d9..0000000
--- a/lib/icl/executor.ml
+++ /dev/null
@@ -1,53 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Error = struct
- open Condition
-
- let multigroup_not_found name =
- condition "multigroup-not-found" "Multigroup not found" ("name" |=| of_string name)
- end
-
- let ( let* ) = Result.bind
- let parse_fqn (s : string) : (Qualified_name.t, Condition.t) result = Qualified_name.try_parse s
-
- let lookup_mg (ctx : Sublanguage_context.t) (mg_name : string) :
- (Management.Multigroup.multigroup, Condition.t) result =
- match ctx.branch#mg_of mg_name with
- | Some mg -> Ok mg
- | None -> Error (Error.multigroup_not_found mg_name)
-
- let convert_binding_expr : Ast.binding_expr -> Constraint.binding_expr = function
- | Ast.Var name -> Constraint.Var name
- | Ast.Const value -> Constraint.Const (Drl.Ast.value_to_abstract value)
-
- let convert_binding (pairs : (string * Ast.binding_expr) list) : Constraint.binding =
- List.fold_left
- (fun acc (key, expr) -> Constraint.BindingMap.add key (convert_binding_expr expr) acc)
- Constraint.BindingMap.empty pairs
-
- let rec convert_body : Ast.constraint_body -> Constraint.t = function
- | Ast.MemberOf {target; binding} ->
- Constraint.member_of ~target ~binding:(convert_binding binding)
- | Ast.Not {body; universe} -> Constraint.not_ ~universe (convert_body body)
- | Ast.And bodies -> Constraint.and_ (List.map convert_body bodies)
- | Ast.Or bodies -> Constraint.or_ (List.map convert_body bodies)
- | Ast.Exists {variable; quantifier; body} ->
- Constraint.exists ~variable ~quantifier (convert_body body)
- | Ast.Forall {variable; quantifier; body} ->
- Constraint.forall ~variable ~quantifier (convert_body body)
-
- let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) :
- (Sublanguage_types.transition_delta * string, Condition.t) result =
- match stmt with
- | Ast.RegisterConstraint {constraint_name; relation_name; body} ->
- let* fqn = parse_fqn relation_name in
- let* mg = lookup_mg ctx fqn.mg in
- let runtime_body = convert_body body in
- let* _bh, new_mg =
- NT.register_constraint ctx.write_handle mg ~constraint_name ~relation_name:fqn.name
- ~body:runtime_body
- in
- ctx.branch#set_mg ~name:fqn.mg new_mg;
- Ok ([fqn.mg, new_mg], "Constraint registered: " ^ constraint_name)
-end
-
-module Memory = Make (Nt.Memory)
diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml
deleted file mode 100644
index 094b0fd..0000000
--- a/lib/icl/parser.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-module Error = struct
- open Condition
-
- let parse_error msg = condition "parse-error" msg empty
-end
-
-let of_sexp sexp =
- match Ast.statement_of_sexp sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-let of_string s =
- match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-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
deleted file mode 100644
index c68077d..0000000
--- a/lib/icl/sublanguage.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Exec = Executor.Make (NT)
-
- type configuration = unit
- type ast = Ast.statement
-
- let name = "icl"
- let parse _ = Ok ()
- let parse_sexp sexp = Parser.of_sexp sexp
-
- let execute ctx ast =
- match Exec.execute ctx ast with
- | Ok (delta, _msg) -> Ok (Sublanguage_types.Transition delta)
- | Error e -> Error e
-end
diff --git a/lib/management/branch.ml b/lib/management/branch.ml
deleted file mode 100644
index 1583b9b..0000000
--- a/lib/management/branch.ml
+++ /dev/null
@@ -1,137 +0,0 @@
-(** Branch registry: named pointers to database tip hashes, plus HEAD tracking.
- Stored in the Physical backend under reserved key prefixes:
- - "branch:<name>" -> serialized { name; tip }
- - "branch_names" -> serialized string list (index for enumeration)
- - "head" -> branch name as raw bytes *)
-
-type t = {name: string; tip: Conventions.Hash.t}
-type head = string
-type error = string
-
-let branch_key name = "branch:" ^ name
-let head_key = "head"
-let names_key = "branch_names"
-
-module Make (Storage : Physical.S) = struct
- module Error = struct
- open Condition
-
- let branch_not_found name =
- condition "branch-not-found" "Branch not found" ("name" |=| of_string name)
- end
-
- let load_names storage =
- match Storage.load_raw storage names_key with
- | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list)
- | _ -> []
-
- let store_names storage names =
- let bytes = Marshal.to_bytes names [] in
- ignore (Storage.store_raw storage names_key bytes)
-
- 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 ()
-
- let checkout storage branch_name =
- let bytes = Bytes.of_string branch_name in
- Storage.store_raw storage head_key bytes
-
- let get_head storage =
- match Storage.load_raw storage head_key with
- | Ok (Some bytes) -> Ok (Some (Bytes.to_string bytes))
- | Ok None -> Ok None
- | Error e -> Error e
-
- 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)
- | 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
- | Ok None -> Error (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
- Ok branches
- (*
- let branch_relation storage : Relation.t =
- let schema =
- Schema.empty |> Schema.add "name" "string" |> Schema.add "hash" "string"
- in
- let mk v = { Attribute.value = Obj.repr v } in
- let rec generator position =
- match position with
- | None -> Generator.Error "random access not supported for public: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 ))
- in
- Relation.make ~hash:None ~name:Prelude.Catalog.branch_rel_name ~schema
- ~tree:None ~constraints:None
- ~cardinality:Conventions.Cardinality.ConstrainedFinite
- ~generator:(Some generator)
- ~membership_criteria:(fun _ _ -> true)
- ~provenance:(Relation.Provenance.Base Prelude.Catalog.branch_rel_name)
- ~lineage:(Relation.Lineage.Base Prelude.Catalog.branch_rel_name) () *)
-
- (* let head_relation storage : Relation.t =
- let schema = Schema.empty |> Schema.add "branch" "string" in
- let mk v = { Attribute.value = Obj.repr v } in
- let generator position =
- match position with
- | None -> Generator.Error "random access not supported for public: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 _ -> Generator.Done
- in
- Relation.make ~hash:None ~name:Prelude.Catalog.head_rel_name ~schema
- ~tree:None ~constraints:None
- ~cardinality:Conventions.Cardinality.ConstrainedFinite
- ~generator:(Some generator)
- ~membership_criteria:(fun _ _ -> true)
- ~provenance:(Relation.Provenance.Base Prelude.Catalog.head_rel_name)
- ~lineage:(Relation.Lineage.Base Prelude.Catalog.head_rel_name) () *)
-end
diff --git a/lib/management/multigroup.ml b/lib/management/multigroup.ml
deleted file mode 100644
index 2882afa..0000000
--- a/lib/management/multigroup.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-(** Multigroup root: a lightweight versioned descriptor that maps relation names
- to content-addressed relation values. The multigroup object owns the B+ tree
- pointer and advances it when relations change. *)
-
-class multigroup ~name:(init_name : Conventions.Name.t) =
- object (_self)
- val name : Conventions.Name.t = init_name
- val relations : Relation.relation BatMap.String.t = BatMap.String.empty
- val timestamp : float = Unix.gettimeofday ()
- method name = name
- method relations = relations
- method timestamp = timestamp
-
- (* TODO: a variant returning (Relation.relation, Condition.t) result *)
- method get_relation rel_name = BatMap.String.find_opt rel_name relations
- method get_relation_names = BatMap.String.fold (fun n _ acc -> n :: acc) relations []
- method has_relation rel_name = BatMap.String.mem rel_name relations
-
- method add_relation (rel : Relation.relation) =
- {<relations = BatMap.String.add rel#name rel relations>}
-
- method remove_relation rel_name = {<relations = BatMap.String.remove rel_name relations>}
-
- method update_relation (rel : Relation.relation) =
- if not (BatMap.String.mem rel#name relations) then {<>}
- else {<relations = BatMap.String.add rel#name rel relations>}
-
- method serialize () : Storable.Multigroup.t =
- { Storable.Multigroup.name;
- relations=
- BatMap.String.bindings relations |> List.map snd |> List.map (fun r -> r#serialize ()) }
- end
-
-let deserialize (bytes : bytes) : (multigroup, string) result =
- (* Reconstruct a multigroup from its persisted payload.
- Only name, schema, and tree_pointer (Merkle root) are restored per
- relation. Constraints are not yet round-tripped — see the TODO in
- storable.ml for the constraint serialisation plan. *)
- try
- let stored = Storable.Multigroup.of_bytes bytes in
- let db = new multigroup ~name:stored.name in
- let db =
- List.fold_left
- (fun mg rel ->
- let relation =
- new Relation.stored
- ~name:rel.Storable.Relation.name ~schema:rel.schema ~constraints:None
- ~cardinality:Conventions.Cardinality.AlephZero ~lineage:None ~provenance:None
- ~membership_criteria:(fun _ -> true )
- in
- let relation =
- if rel.tree_pointer = "" then relation
- else relation#set_tree_pointer (Some rel.tree_pointer)
- in
- mg#add_relation (relation :> Relation.relation) )
- db stored.relations
- in
- Ok db
- with Invalid_argument message -> Error message
diff --git a/lib/management/physical.ml b/lib/management/physical.ml
deleted file mode 100644
index b896330..0000000
--- a/lib/management/physical.ml
+++ /dev/null
@@ -1,198 +0,0 @@
-(** 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.).
-
- 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
- include Configuration.CONFIGURABLE
-
- type connection
-
- (** Connect to the storage backend *)
- val connect : configuration -> (connection, Condition.t) result
-
- (** Disconnect from the backend *)
- val disconnect : connection -> unit
-
- (** Get a value by its hash. Returns None if not found. *)
- val get : connection -> Conventions.Hash.t -> (bytes option, Condition.t) result
-
- (** Store a value at its hash *)
- val put : connection -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result
-
- (** Check if a hash exists *)
- val exists : connection -> Conventions.Hash.t -> (bool, Condition.t) result
-
- (** Begin a transaction *)
- val begin_transaction : connection -> (unit, Condition.t) result
-
- (** Commit a transaction *)
- val commit : connection -> (unit, Condition.t) result
-
- (** Rollback a transaction *)
- val rollback : connection -> (unit, Condition.t) result
-
- (** Batch get multiple values *)
- val get_many : connection -> Conventions.Hash.t list -> (bytes option list, Condition.t) result
-
- (** Batch put multiple values *)
- val put_many : connection -> (Conventions.Hash.t * bytes) list -> (unit, Condition.t) result
-end
-
-(** Storage operations built on top of a backend *)
-module type S = sig
- include Configuration.CONFIGURABLE
-
- type t
-
- (** Create a storage instance from a backend connection *)
- val create : configuration -> (t, Condition.t) result
-
- (** Close the storage *)
- val close : t -> unit
-
- (** Store an attribute value, returns its hash *)
- val store_attribute : t -> Conventions.AbstractValue.t -> (Conventions.Hash.t, Condition.t) result
-
- (** Load an attribute value by hash *)
- val load_attribute :
- t -> Conventions.Hash.t -> (Conventions.AbstractValue.t option, Condition.t) result
-
- (** Store raw bytes at a hash *)
- val store_raw : t -> Conventions.Hash.t -> bytes -> (unit, Condition.t) result
-
- (** Load raw bytes by hash *)
- val load_raw : t -> Conventions.Hash.t -> (bytes option, Condition.t) result
-
- (** Check if a hash exists *)
- val exists : t -> Conventions.Hash.t -> (bool, Condition.t) result
-
- (** Execute a function within a transaction *)
- val with_transaction : t -> (unit -> ('a, Condition.t) result) -> ('a, Condition.t) result
-end
-
-(** Functor to create storage operations from a backend *)
-module Make (B : BACKEND) : S with type configuration = B.configuration = struct
- type configuration = B.configuration
- type t = B.connection
-
- let parse = B.parse
- let create config = B.connect config
- 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
-
- let load_attribute conn hash =
- match B.get conn hash with
- | Ok (Some bytes) -> Ok (Some (Marshal.from_bytes bytes 0))
- | 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 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 )
-end
-
-(** In-memory backend for testing and development *)
-module MemoryBackend : BACKEND with type configuration = unit = struct
- type configuration = unit
-
- type connection =
- { data: (string, bytes) Hashtbl.t;
- mutable in_transaction: bool;
- mutable transaction_buffer: (string * bytes) list }
-
- module Error = struct
- open Condition
-
- (* TODO: more structure *)
- let parse_error msg = condition "parse-error" msg empty
-
- let already_in_transaction =
- condition "already-in-transaction" "Already inside a transaction" empty
-
- let not_in_transaction = condition "not-in-transaction" "Not inside a transaction" empty
- end
-
- let parse sexp =
- match sexp with
- | Sexplib.Sexp.List [] -> Ok ()
- | _ ->
- Error
- (Error.parse_error
- (Printf.sprintf "memory backend takes no configuration, got: %s"
- (Sexplib.Sexp.to_string sexp) ) )
-
- let connect () = Ok {data= Hashtbl.create 1024; in_transaction= false; transaction_buffer= []}
- let disconnect _ = ()
- 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
- Hashtbl.replace conn.data hash value;
- Ok ()
- end
-
- let exists conn hash = Ok (Hashtbl.mem conn.data hash)
-
- let begin_transaction conn =
- if conn.in_transaction then Error Error.already_in_transaction
- else begin
- conn.in_transaction <- true;
- conn.transaction_buffer <- [];
- Ok ()
- end
-
- let commit conn =
- if not conn.in_transaction then Error Error.not_in_transaction
- else begin
- List.iter (fun (hash, value) -> Hashtbl.replace conn.data hash value) conn.transaction_buffer;
- conn.in_transaction <- false;
- conn.transaction_buffer <- [];
- Ok ()
- end
-
- let rollback conn =
- if not conn.in_transaction then Error Error.not_in_transaction
- else begin
- conn.in_transaction <- false;
- conn.transaction_buffer <- [];
- Ok ()
- end
-
- let get_many conn hashes = Ok (List.map (fun h -> Hashtbl.find_opt conn.data h) hashes)
-
- let put_many conn pairs =
- List.iter
- (fun (hash, value) ->
- if conn.in_transaction then
- conn.transaction_buffer <- (hash, value) :: conn.transaction_buffer
- else Hashtbl.replace conn.data hash value )
- pairs;
- Ok ()
-end
-
-(** Default in-memory storage for development *)
-module Memory = Make (MemoryBackend)
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
deleted file mode 100644
index 2b7a421..0000000
--- a/lib/manipulation.ml
+++ /dev/null
@@ -1,114 +0,0 @@
-(** Multigroup manipulation operations.
-
- This module implements the core operations for the relational engine:
- - Multigroup creation
- - Relation creation and deletion
- - Tuple insertion and deletion
- - Query operations
-
- All operations are immutable: they return new multigroup/relation states
- rather than modifying existing ones. The storage layer handles persistence.
-
- This is a functor that takes a storage backend, ensuring all tuple data is
- properly persisted to the content-addressed store. *)
-
-(** Functor to create manipulation operations with a storage backend *)
-module Make (Storage : Management.Physical.S) = struct
- type storage = Storage.t
- type error = Condition.t
-
- module Error = struct
- open Condition
-
- (* TODO: more specific errors *)
- let storage_error message = condition "storage-error" message empty
- end
-
- let ( let* ) = Result.bind
-
- (* State Persistence - Store relation and database states *)
-
- (** Store a relation state to storage *)
- let store_relation (storage : storage) (relation : Relation.relation) : (unit, error) Result.t =
- match
- Storage.store_raw storage relation#hash (Storable.Relation.to_bytes @@ relation#serialize ())
- with
- | Error _ -> Error (Error.storage_error "Failed to store relation")
- | Ok () -> Ok ()
-
- (** Store a database state to storage. Keyed by [db#name]; content-hashing of
- mgs is no longer maintained on the Sakura side — the kernel owns mg
- content addressing. *)
- let store_multigroup (storage : storage) (db : Management.Multigroup.multigroup) :
- (unit, error) Result.t =
- match Storage.store_raw storage db#name (Storable.Multigroup.to_bytes @@ db#serialize ()) with
- | Error _ -> Error (Error.storage_error "Failed to store multigroup")
- | Ok () -> Ok ()
-
- (** Load a relation state from storage by hash *)
- let load_relation (storage : storage) (rel_hash : Conventions.Hash.t) :
- (Relation.stored option, error) Result.t =
- match Storage.load_raw storage rel_hash with
- | Error _ -> Error (Error.storage_error "Failed to load relation")
- | Ok None -> Ok None
- | Ok (Some bytes) ->
- let _stored = Storable.Relation.of_bytes bytes in
- let name = failwith "NOT IMPLEMENTED" in
- let schema = failwith "NOT IMPLEMENTED" in
- let constraints = failwith "NOT IMPLEMENTED" in
- let cardinality = failwith "NOT IMPLEMENTED" in
- let membership_criteria = Constraint.build_membership_criteria ~_name:name ~schema in
- let relation =
- new Relation.stored
- ~name ~schema ~constraints ~cardinality ~membership_criteria ~provenance:None
- ~lineage:None
- in
- Ok (Some relation)
-
- let load_multigroup (storage : storage) (mg_hash : Conventions.Hash.t) :
- (Management.Multigroup.multigroup option, error) Result.t =
- match Storage.load_raw storage mg_hash with
- | Error _ -> Error (Error.storage_error "Failed to load multigroup")
- | Ok None -> Ok None
- | Ok (Some bytes) ->
- (* TODO: Properly deserialize multigroup state *)
- let _stored = Storable.Multigroup.of_bytes bytes in
- let name = failwith "NOT IMPLEMENTED" in
- let mg = new Management.Multigroup.multigroup ~name in
- Ok (Some mg)
-
- (* Tuple Operations - Storage Integrated *)
-
- (** Store each attribute value and return map of attr_name -> attr_hash *)
- let store_attributes (_storage : storage) (_tuple : Tuple.materialized) :
- ((string * Conventions.Hash.t) list, error) Result.t =
- failwith "NOT IMPLEMENTED"
-
- (** Load a tuple from storage by its hash *)
- let load_tuple (storage : storage) (tuple_hash : Conventions.Hash.t) :
- (Tuple.materialized option, error) Result.t =
- match Storage.load_raw storage tuple_hash with
- | Error _ -> Error (Error.storage_error "Failed to load tuple")
- | Ok None -> Ok None
- | Ok (Some tuple_bytes) ->
- let _stored = Storable.Tuple.of_bytes tuple_bytes in
- let attributes = failwith "NOT IMPLEMENTED" in
- let relation = failwith "NOT IMPLEMENTED" in
- let rec load_attrs acc = function
- | [] -> Ok (List.rev acc)
- | (name, attr_hash) :: rest -> (
- match Storage.load_raw storage attr_hash with
- | Error _ -> Error (Error.storage_error ("Failed to load attribute: " ^ name))
- | Ok None -> Error (Error.storage_error ("Attribute not found: " ^ name))
- | Ok (Some value_bytes) ->
- let value : Conventions.AbstractValue.t = Marshal.from_bytes value_bytes 0 in
- let attr : Attribute.materialized = {value} in
- load_attrs ((name, attr) :: acc) rest )
- in
- load_attrs [] attributes
- |> Result.map
- (List.fold_left
- (fun m (k, v) -> Tuple.AttributeMap.add k v m)
- Tuple.AttributeMap.empty )
- |> Result.map (fun attributes -> Some {Tuple.relation; attributes})
-end
diff --git a/lib/nt_ffi.ml b/lib/nt_ffi.ml
deleted file mode 100644
index 4d73c32..0000000
--- a/lib/nt_ffi.ml
+++ /dev/null
@@ -1,178 +0,0 @@
-(* Low-level ctypes bindings to RNT_C_API.h.
- This module is internal to Nt — never import it anywhere else. *)
-
-open Ctypes
-open Foreign
-
-let fn name typ = foreign name typ
-
-(* Runtime ----------------------------------------------------------------- *)
-let rnt_init = fn "rnt_init" (string @-> string @-> returning int)
-
-(* Auth -------------------------------------------------------------------- *)
-let rnt_firewall = fn "rnt_firewall" (string @-> ptr (ptr char) @-> returning int)
-
-(* Session lifecycle ------------------------------------------------------- *)
-let rnt_session_open = fn "rnt_session_open" (ptr void @-> ptr (ptr char) @-> returning int)
-let rnt_session_close = fn "rnt_session_close" (string @-> returning int)
-
-let rnt_session_set_branch =
- fn "rnt_session_set_branch" (string @-> string @-> string @-> returning int)
-
-(* Ephemeral relations ------------------------------------------------------ *)
-
-(* rnt_generator_fn: (ctx, args, offset, limit, sink) -> int.
- OCaml closures passed here cross into C; the closure must stay reachable
- for as long as RNT may invoke it (Nt retains them, see
- Nt.retained_generators). *)
-let rnt_generator_fn =
- funptr (ptr void @-> string @-> size_t @-> size_t @-> ptr void @-> returning int)
-
-let rnt_sink_emit = fn "rnt_sink_emit" (ptr void @-> string @-> returning int)
-
-let rnt_register_ephemeral_relation =
- fn "rnt_register_ephemeral_relation"
- ( string
- @-> int
- @-> string
- @-> rnt_generator_fn
- @-> ptr void
- @-> int
- @-> string
- @-> string
- @-> string
- @-> ptr (ptr char)
- @-> returning int )
-
-let rnt_drop_ephemeral_relation =
- fn "rnt_drop_ephemeral_relation" (string @-> string @-> returning int)
-
-(* Handle lifecycle -------------------------------------------------------- *)
-let rnt_open_handle = fn "rnt_open_handle" (string @-> ptr void @-> returning (ptr void))
-let rnt_close_handle = fn "rnt_close_handle" (ptr void @-> returning int)
-
-(* Branch hash-pointer ----------------------------------------------------- *)
-let rnt_branch_target = fn "rnt_branch_target" (ptr void @-> ptr (ptr char) @-> returning int)
-let rnt_branch_advance = fn "rnt_branch_advance" (string @-> string @-> returning int)
-
-(* Object registration ----------------------------------------------------- *)
-let rnt_register_relation = fn "rnt_register_relation" (string @-> returning int)
-let rnt_register_branch = fn "rnt_register_branch" (string @-> string @-> returning int)
-
-(* Branch / snapshot relation enumeration ----------------------------------- *)
-let rnt_list_relations = fn "rnt_list_relations" (string @-> ptr (ptr char) @-> returning int)
-
-let rnt_list_branch_multigroups =
- fn "rnt_list_branch_multigroups" (string @-> ptr (ptr char) @-> returning int)
-
-let rnt_list_snapshot_relations =
- fn "rnt_list_snapshot_relations" (string @-> ptr (ptr char) @-> returning int)
-
-(* Tuple storage ----------------------------------------------------------- *)
-let rnt_link_tuple = fn "rnt_link_tuple" (string @-> string @-> ptr (ptr char) @-> returning int)
-let rnt_unlink_tuple = fn "rnt_unlink_tuple" (string @-> string @-> returning int)
-let rnt_clear_relation = fn "rnt_clear_relation" (string @-> returning int)
-let rnt_relation_root = fn "rnt_relation_root" (string @-> ptr (ptr char) @-> returning int)
-
-(* Cursor and VM ----------------------------------------------------------- *)
-let rnt_cursor_open = fn "rnt_cursor_open" (ptr void @-> returning (ptr void))
-let rnt_cursor_next = fn "rnt_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int)
-let rnt_cursor_close = fn "rnt_cursor_close" (ptr void @-> returning int)
-
-(* VM plan builder --------------------------------------------------------- *)
-
-(* For PlanAction in RNT_C_API.h, where one context struct per operator is laid
- side by side (no unions unfortunately as ctypes has no union support 🤡, and
- the C side reads only the member matching [operation]). Strings are passed
- as [ptr char]; the caller owns the backing CArray and must keep it alive across
- the rnt_plan_assemble call (the C side copies immediately). *)
-
-type plan_args_scan
-
-let plan_args_scan : plan_args_scan structure typ = structure "PlanArgsScan"
-let scan_relation_path = field plan_args_scan "relation_path" (ptr char)
-let () = seal plan_args_scan
-
-type plan_args_join
-
-let plan_args_join : plan_args_join structure typ = structure "PlanArgsJoin"
-let join_left = field plan_args_join "left" (ptr void)
-let join_right = field plan_args_join "right" (ptr void)
-let join_attrs = field plan_args_join "attrs" (ptr (ptr char))
-let () = seal plan_args_join
-
-type plan_args_take
-
-let plan_args_take : plan_args_take structure typ = structure "PlanArgsTake"
-let take_source = field plan_args_take "source" (ptr void)
-let take_limit = field plan_args_take "limit" size_t
-let () = seal plan_args_take
-
-type plan_args_project
-
-let plan_args_project : plan_args_project structure typ = structure "PlanArgsProject"
-let project_source = field plan_args_project "source" (ptr void)
-let project_attrs = field plan_args_project "attrs" (ptr (ptr char))
-let () = seal plan_args_project
-
-type plan_action
-
-let plan_action : plan_action structure typ = structure "PlanAction"
-let action_operation = field plan_action "operation" int
-let action_scan = field plan_action "scan" plan_args_scan
-let action_join = field plan_action "join" plan_args_join
-let action_take = field plan_action "take" plan_args_take
-let action_project = field plan_action "project" plan_args_project
-let () = seal plan_action
-
-(* nt::Operation values, RNT include/VM.h *)
-let fol_operation_scan = 1
-let fol_operation_join = 2
-let fol_operation_take = 3
-let fol_operation_project = 4
-let rnt_plan_assemble = fn "rnt_plan_assemble" (plan_action @-> returning (ptr void))
-let rnt_plan_free = fn "rnt_plan_free" (ptr void @-> returning void)
-let rnt_vm_execute_plan = fn "rnt_vm_execute_plan" (ptr void @-> returning (ptr void))
-let rnt_vm_cursor_next = fn "rnt_vm_cursor_next" (ptr void @-> ptr (ptr char) @-> returning int)
-let rnt_vm_cursor_close = fn "rnt_vm_cursor_close" (ptr void @-> returning int)
-
-(* Memory management ------------------------------------------------------- *)
-let rnt_free_string = fn "rnt_free_string" (ptr char @-> returning void)
-let rnt_free_bytes = fn "rnt_free_bytes" (ptr uint8_t @-> returning void)
-
-(* --------------------------------------------------------------------------
- Helpers shared by Nt (not exported from the library module)
- -------------------------------------------------------------------------- *)
-
-let null_char_ptr : char ptr = from_voidp char null
-
-let cstring (s : string) : char CArray.t =
- let n = String.length s in
- let arr = CArray.make char (n + 1) in
- String.iteri (CArray.set arr) s;
- CArray.set arr n '\000';
- arr
-
-(* Reads a null-terminated C string from a char pointer, then frees it. *)
-let consume_cstring (p : char ptr) : string =
- let n = ref 0 in
- while !@(p +@ !n) <> '\000' do
- incr n
- done;
- let s = string_from_ptr p ~length:!n in
- rnt_free_string p; s
-
-(* Allocates a char* out-parameter, calls [f], returns the rc and string. *)
-let with_out_string (f : char ptr ptr -> int) : int * string option =
- let pp = allocate (ptr char) null_char_ptr in
- let rc = f pp in
- let p = !@pp in
- if is_null p then rc, None else rc, Some (consume_cstring p)
-
-(* Converts a void* (returned from open_handle / cursor_open) to nativeint.
- Returns None when the pointer is NULL (failure). *)
-let ptr_to_opt (p : unit ptr) : nativeint option =
- if is_null p then None else Some (raw_address_of_ptr p)
-
-(* Converts a stored nativeint back to a void* for API calls. *)
-let nint_to_ptr (n : nativeint) : unit ptr = ptr_of_raw_address n
diff --git a/lib/prl/ast.ml b/lib/prl/ast.ml
deleted file mode 100644
index ab63c31..0000000
--- a/lib/prl/ast.ml
+++ /dev/null
@@ -1,15 +0,0 @@
-open Sexplib.Std
-
-type function_predicate =
- { name: string;
- schema: (string * string) list;
- symbol: string;
- purity: Conventions.Purity.t;
- cardinality: Conventions.Cardinality.t }
-[@@deriving sexp]
-
-type statement =
- | LoadLibrary of string
- | DefineFunctionPredicate of function_predicate
- | ListFunctionPredicates
-[@@deriving sexp]
diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml
deleted file mode 100644
index 4a055ae..0000000
--- a/lib/prl/executor.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Error = struct
- open Condition
-
- (* TODO: more structure *)
- let parse_error msg = condition "parse-error" msg empty
- let runtime_error msg = condition "runtime-error" msg empty
-
- let unknown_plugin_symbol name =
- condition "unknown-plugin-symbol" "Unknown plugin" ("name" |=| of_string name)
-
- let relation_not_found name =
- condition "relation-not-found" "Relation not found" ("name" |=| of_string name)
- end
-
- let ( let* ) = Result.bind
-
- (* TODO: PRL function predicates are OCaml shared-library callbacks that
- produce tuples at runtime. To make their output joinable inside the
- Tarski VM they need to be materialised into a temporary relation in the
- InMemoryBackend and then SCANned like any other stored relation. This
- requires a `rnt_register_ephemeral_relation` C API call that does not
- yet exist. Disable PRL execution until that bridge is in place. *)
-
- let execute (_ctx : Sublanguage_context.t) (_stmt : Ast.statement) :
- (Sublanguage_types.result, Condition.t) result =
- Error
- (Error.runtime_error
- "PRL execution is temporarily disabled pending VM callback-cursor support" )
-
- let _execute_load_library _ctx _path = Error (Error.runtime_error "PRL disabled")
-
- let _execute_define_function_predicate _ctx (_spec : Ast.function_predicate) =
- let* _ = Ok () in
- Error (Error.runtime_error "PRL disabled")
-
- let _execute_list_function_predicates _ctx = Error (Error.runtime_error "PRL disabled")
-end
diff --git a/lib/prl/parser.ml b/lib/prl/parser.ml
deleted file mode 100644
index e009b97..0000000
--- a/lib/prl/parser.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-module Error = struct
- open Condition
-
- let parse_error msg = condition "parse-error" msg empty
-end
-
-let of_sexp sexp =
- let sexp = match sexp with Sexplib.Sexp.List [atom] -> atom | other -> other in
- match Ast.statement_of_sexp sexp with
- | stmt -> Ok stmt
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
-
-let of_string s = of_sexp (Sexplib.Sexp.of_string s)
-let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/prl/runtime.ml b/lib/prl/runtime.ml
deleted file mode 100644
index 103b5c1..0000000
--- a/lib/prl/runtime.ml
+++ /dev/null
@@ -1,75 +0,0 @@
-type t = {loaded_libraries: (string, unit) Hashtbl.t; mutex: Mutex.t}
-
-let state : t = {loaded_libraries= Hashtbl.create 16; mutex= Mutex.create ()}
-
-let load_library path : (unit, string) result =
- Mutex.protect state.mutex (fun () ->
- if Hashtbl.mem state.loaded_libraries path then Ok ()
- else
- try
- Dynlink.loadfile path;
- Hashtbl.replace state.loaded_libraries path ();
- Ok ()
- with Dynlink.Error e -> Error (Dynlink.error_message e) )
-
-(* Convert an engine materialized tuple to the plugin's (string * Obj.t) list format. *)
-let to_plugin_row (schema : Schema.t) (tuple : Tuple.materialized) : Sakura_prl_api.tuple option =
- let rec go acc = function
- | [] -> Some (List.rev acc)
- | (attr_name, _) :: rest -> (
- match Tuple.AttributeMap.find_opt attr_name tuple.attributes with
- | None -> None
- | Some attr -> go ((attr_name, attr.Attribute.value) :: acc) rest )
- in
- go [] schema
-
-(* Convert a plugin row back to an engine materialized tuple. *)
-let of_plugin_row relation_name (schema : Schema.t) (row : Sakura_prl_api.tuple) :
- Tuple.materialized option =
- let rec go acc = function
- | [] -> Some {Tuple.relation= relation_name; attributes= acc}
- | (attr_name, _) :: rest -> (
- match List.assoc_opt attr_name row with
- | None -> None
- | Some value -> go (Tuple.AttributeMap.add attr_name {Attribute.value} acc) rest )
- in
- go Tuple.AttributeMap.empty schema
-
-(* Wrap a list of plugin rows as a generator. Uses an array for O(1) indexing. *)
-let rows_to_generator relation_name schema (rows : Sakura_prl_api.tuple list) : Generator.t =
- let arr = Array.of_list rows in
- let n = Array.length arr in
- let rec gen i _pos =
- if i >= n then Generator.Done
- else
- match of_plugin_row relation_name schema arr.(i) with
- | None -> Generator.Error "Plugin row does not conform to predicate schema."
- | Some tuple -> Generator.Value (Tuple.Materialized tuple, gen (i + 1))
- in
- gen 0
-
-let make_generator relation_name schema (impl : Sakura_prl_api.implementation)
- (bindings : Sakura_prl_api.tuple) : Generator.t =
- match impl.produce with
- | None -> fun _ -> Generator.Done
- | Some produce -> (
- let rows_result = lazy (produce bindings) in
- fun _pos ->
- match Lazy.force rows_result with
- | Error e -> Generator.Error e
- | Ok rows -> rows_to_generator relation_name schema rows _pos )
-
-let make_producer relation_name schema (impl : Sakura_prl_api.implementation) : Relation.producer =
- fun bindings -> make_generator relation_name schema impl bindings
-
-let make_membership_criteria schema (impl : Sakura_prl_api.implementation) : Tuple.t -> bool =
- match impl.membership_criteria with
- | None -> fun _ -> false
- | Some check -> (
- (* fun _tree_of -> *)
- function
- | Tuple.NonMaterialized _ -> false
- | Tuple.Materialized m -> (
- match to_plugin_row schema m with
- | None -> false
- | Some row -> ( match check row with Ok b -> b | Error _ -> false ) ) )
diff --git a/lib/prl/sublanguage.ml b/lib/prl/sublanguage.ml
deleted file mode 100644
index 405d266..0000000
--- a/lib/prl/sublanguage.ml
+++ /dev/null
@@ -1,11 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Exec = Executor.Make (NT)
-
- type configuration = unit
- type ast = Ast.statement
-
- let name = "prl"
- let parse _ = Ok ()
- let parse_sexp sexp = Parser.of_sexp sexp
- let execute = Exec.execute
-end
diff --git a/lib/qualified_name.ml b/lib/qualified_name.ml
deleted file mode 100644
index a73774e..0000000
--- a/lib/qualified_name.ml
+++ /dev/null
@@ -1,38 +0,0 @@
-(** Fully qualified relation reference: [mg:rel_name].
-
- The first colon separates the multigroup name from the relation name; any
- further colons are part of the relation name verbatim.
-
- Examples:
- - ["warehouse:orders"] -> mg=["warehouse"], name=["orders"]
- - ["warehouse:public:orders"] -> mg=["warehouse"], name=["public:orders"]
- - ["sakura:public:relation"] -> mg=["sakura"], name=["public:relation"]
-
- A reference with no leading [<mg>:] segment is a parse error — callers must
- supply the mg explicitly. *)
-
-type t = {mg: string; name: string}
-
-module Error = struct
- open Condition
-
- let unqualified_name name =
- condition "unqualified-name" "A qualified name was expected, but an unqualified one was given"
- ("name" |=| of_string name)
-end
-
-exception Unqualified of string
-
-let parse (s : string) : t =
- match String.index_opt s ':' with
- | None -> raise (Unqualified s)
- | Some i ->
- let mg = String.sub s 0 i in
- let name = String.sub s (i + 1) (String.length s - i - 1) in
- if mg = "" || name = "" then raise (Unqualified s) else {mg; name}
-
-let try_parse (s : string) : (t, Condition.t) result =
- try Ok (parse s) with Unqualified s -> Error (Error.unqualified_name s)
-
-let make ~mg ~name = {mg; name}
-let to_string {mg; name} = mg ^ ":" ^ name
diff --git a/lib/qualified_name.mli b/lib/qualified_name.mli
deleted file mode 100644
index 15f80d1..0000000
--- a/lib/qualified_name.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(** Fully qualified relation reference: [mg:rel_name].
-
- The first colon separates the multigroup name from the relation name; any
- further colons are part of the relation name verbatim. *)
-
-type t = {mg: string; name: string}
-
-exception Unqualified of string
-
-(** Splits on the first [:]. Raises [Unqualified] when no mg segment is present
- (i.e. no colon, or empty mg / empty name). *)
-val parse : string -> t
-
-val try_parse : string -> (t, Condition.t) result
-val make : mg:string -> name:string -> t
-val to_string : t -> string
diff --git a/lib/relation.ml b/lib/relation.ml
deleted file mode 100644
index 863316b..0000000
--- a/lib/relation.ml
+++ /dev/null
@@ -1,189 +0,0 @@
-(** Relation: a lightweight versioned root describing a named collection of
- tuples. Physical storage owns the tuple B+ tree; this object holds only
- metadata and a tree pointer.
-
- Class hierarchy:
- - [relation] — base, storable, has membership_criteria/provenance/lineage
- - [ephemeral_relation] — adds a generator (query-time computed, not stored)
- - [pseudo_relation] — adds a producer (system-defined, not stored)
- - [domain] — adds a generator (system or user defined, not necessarily
- stored) *)
-
-module RelationConstraint = struct
- type name = string
- type t = (name * Constraint.t) list
-end
-
-module Lineage = struct
- (** Tracks which relational algebra operations produced the tuples. Lives in
- the relation, but refers to the tuple. *)
- type t =
- | Base of Conventions.Name.t
- | Select of t
- | Project of Conventions.Name.t list * t
- | Join of t * t
- | ThetaJoin of t * t
- | Sort of t
- | Take of t
-end
-
-module Provenance = struct
- (** Tracks which base relation each attribute originates from. Lives on the
- relation and refers to the `entity group`. *)
- type source = {relation: Conventions.Name.t; attribute: string}
-
- type t =
- | Undefined
- | Base of Conventions.Name.t
- | Sources of source list BatMap.String.t
- (** Maps attribute name -> list of sources (multiple after joins) *)
-
- let base ~relation ~attributes : t =
- Sources
- (List.fold_left
- (fun acc attr -> BatMap.String.add attr [{relation; attribute= attr}] acc)
- BatMap.String.empty attributes )
-
- let empty : t = Sources BatMap.String.empty
- let undefined : t = Undefined
-end
-
-type producer = (string * Conventions.AbstractValue.t) list -> Generator.t
-type kind = [`Stored | `Ephemeral | `Pseudo | `Domain]
-
-class virtual relation =
- object (_self)
- method virtual kind : kind
- method virtual name : Conventions.Name.t
- method virtual schema : Schema.t
- method virtual hash : Conventions.Hash.t
- method virtual constraints : RelationConstraint.t option
- method virtual cardinality : Conventions.Cardinality.t
- method virtual lineage : Lineage.t
- method virtual provenance : Provenance.t
- method virtual membership_criteria : Tuple.t -> bool
- method virtual timestamp : float
- method virtual serialize : unit -> Storable.Relation.t
- end
-
-class stored ~name:(init_name : Conventions.Name.t) ~schema:(init_schema : Schema.t)
- ~constraints:(init_constraints : RelationConstraint.t option)
- ~cardinality:(init_cardinality : Conventions.Cardinality.t)
- ~membership_criteria:(init_membership : Tuple.t -> bool)
- ~lineage:(init_lineage : Lineage.t option) ~provenance:(init_provenance : Provenance.t option) =
- object
- inherit relation
- val name = init_name
- val schema = init_schema
- val tree_pointer : Conventions.Hash.t option = None
- val constraints = init_constraints
- val cardinality = init_cardinality
- val membership_criteria = init_membership
- val timestamp = Unix.gettimeofday ()
- val lineage = Option.value init_lineage ~default:(Lineage.Base init_name)
-
- val provenance =
- Option.value init_provenance
- ~default:(Provenance.base ~relation:init_name ~attributes:(Schema.attributes init_schema))
-
- method name = name
- method kind = `Stored
- method hash = Option.value tree_pointer ~default:""
- method schema = schema
- method tree_pointer = tree_pointer
- method constraints = constraints
- method cardinality = cardinality
- method membership_criteria = membership_criteria
- method timestamp = timestamp
- method lineage = lineage
- method provenance = provenance
- method set_tree_pointer tp = {<tree_pointer = tp; timestamp = Unix.gettimeofday ()>}
- method set_cardinality c = {<cardinality = c>}
- method set_constraints c = {<constraints = c>}
-
- method serialize () =
- {Storable.Relation.name; schema; tree_pointer= Option.value tree_pointer ~default:""}
- end
-
-class ephemeral ~name:(init_name : Conventions.Name.t) ~schema ~constraints ~cardinality
- ~membership_criteria ~lineage ~provenance ~generator:(init_generator : Generator.t) =
- object
- inherit relation
- val name : Conventions.Name.t = init_name
- val schema : Schema.t = schema
- val generator : Generator.t = init_generator
- val constraints = constraints
- val cardinality = cardinality
- val membership_criteria = membership_criteria
- val lineage = Option.value lineage ~default:(Lineage.Base init_name)
- val provenance = Option.value provenance ~default:(Provenance.Base init_name)
- val timestamp = Unix.gettimeofday ()
- method name = name
- method kind = `Ephemeral
- method schema = schema
- method generator = generator
- method hash = Conventions.Hash.hash_text (name ^ "ephemeral")
- method constraints = constraints
- method cardinality = cardinality
- method membership_criteria = membership_criteria
- method lineage = lineage
- method provenance = provenance
- method timestamp = timestamp
- method serialize () = failwith "Ephemeral relations cannot be serialized directly"
- end
-
-class pseudo ~name:(init_name : Conventions.Name.t) ~schema ~constraints ~cardinality
- ~membership_criteria ~lineage ~provenance ~producer:(init_producer : producer) =
- object
- inherit relation
- val name = init_name
- val schema = schema
- val producer = init_producer
- val constraints = constraints
- val cardinality = cardinality
- val membership_criteria = membership_criteria
- val lineage = Option.value lineage ~default:(Lineage.Base init_name)
- val provenance = provenance
- val timestamp = Unix.gettimeofday ()
- method name = name
- method kind = `Pseudo
- method schema = schema
- method producer = producer
-
- method as_generator (bindings : (string * Conventions.AbstractValue.t) list) : Generator.t =
- producer bindings
-
- method hash = Conventions.Hash.hash_text (name ^ "pseudo")
- method constraints = constraints
- method cardinality = cardinality
- method membership_criteria = membership_criteria
- method lineage = lineage
- method provenance = provenance
- method timestamp = timestamp
-
- (* TODO: Remove this from the virtual definition *)
- method serialize () = failwith "Pseudo relations are procedural"
- end
-
-let deserialize_stored (_bytes : bytes) : (stored, string) result =
- try
- let stored = Storable.Relation.of_bytes _bytes in
- let membership_criteria =
- Constraint.build_membership_criteria ~_name:stored.name ~schema:stored.schema
- in
- Ok
- (new stored
- ~name:stored.name ~schema:stored.schema ~constraints:None
- ~cardinality:Conventions.Cardinality.ConstrainedFinite ~membership_criteria ~lineage:None
- ~provenance:None )
- with Invalid_argument message -> Error message
-
-class domain ~name ~schema ~constraints ~cardinality ~membership_criteria ~lineage ~provenance
- ~generator =
- object
- inherit
- ephemeral
- ~name ~schema ~constraints ~cardinality ~membership_criteria ~lineage ~provenance ~generator
-
- method! kind = `Domain
- end
diff --git a/lib/schema.ml b/lib/schema.ml
deleted file mode 100644
index cc277a5..0000000
--- a/lib/schema.ml
+++ /dev/null
@@ -1,14 +0,0 @@
-(** 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:
- - Hashing relations (schema is part of the relation identity)
- - Validation (checking tuple membership)
- - Persistence (storing and loading relations with their structure) *)
-
-type t = (string * string) list
-
-let empty : t = []
-let add name domain_name (schema : t) : t = (name, domain_name) :: schema
-let attributes (schema : t) = List.map fst schema
-let to_string schema = List.map (fun (n, t) -> n ^ ":" ^ t) schema |> String.concat ","
diff --git a/lib/scl/ast.ml b/lib/scl/ast.ml
deleted file mode 100644
index 41a5239..0000000
--- a/lib/scl/ast.ml
+++ /dev/null
@@ -1,7 +0,0 @@
-open Sexplib.Std
-
-type statement =
- | Begin of {query: Drl.Ast.query; limit: int option}
- | Fetch of {cursor: string; limit: int option}
- | Close of {cursor: string}
-[@@deriving sexp]
diff --git a/lib/scl/executor.ml b/lib/scl/executor.ml
deleted file mode 100644
index 5fadc6d..0000000
--- a/lib/scl/executor.ml
+++ /dev/null
@@ -1,29 +0,0 @@
-let default_batch = 50
-
-type cursor_batch = {cursor_id: string; rows: Tuple.materialized list; has_more: bool}
-type exec_result = Batch of cursor_batch | Closed of Sublanguage_types.transition_delta
-
-module Make (NT : Nt.S) = struct
- module DrlExec = Drl.Executor.Make (NT)
-
- module Error = struct
- open Condition
-
- (* TODO: more structure *)
- let cursor_error msg = condition "cursor-error" msg empty
- end
-
- let ( let* ) = Result.bind
-
- let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) :
- (exec_result, Condition.t) result =
- ignore default_batch;
- match stmt with
- | Ast.Begin _ -> Error (Error.cursor_error "cursors not yet implemented")
- | Ast.Fetch _ -> Error (Error.cursor_error "cursors not yet implemented")
- | Ast.Close _ ->
- let* () = Ok () in
- Ok (Closed ctx.branch#multigroups)
-end
-
-module Memory = Make (Nt.Memory)
diff --git a/lib/scl/parser.ml b/lib/scl/parser.ml
deleted file mode 100644
index 670139b..0000000
--- a/lib/scl/parser.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-module Error = struct
- open Condition
-
- let parse_error msg = condition "parse-error" msg empty
-end
-
-let validate = function
- | (Ast.Begin {limit= Some limit; _} | Ast.Fetch {limit= Some limit; _}) when limit <= 0 ->
- Error (Error.parse_error "The provision of `limit` is expected to be positive.")
- | stmt -> Ok stmt
-
-let of_sexp sexp =
- match Ast.statement_of_sexp sexp with
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
- | stmt -> validate stmt
-
-let of_string s =
- match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
- | exception exn -> Error (Error.parse_error (Printexc.to_string exn))
- | stmt -> validate stmt
-
-let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/scl/sublanguage.ml b/lib/scl/sublanguage.ml
deleted file mode 100644
index 526e7a2..0000000
--- a/lib/scl/sublanguage.ml
+++ /dev/null
@@ -1,17 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Exec = Executor.Make (NT)
-
- type configuration = unit
- type ast = Ast.statement
-
- let name = "scl"
- let parse _ = Ok ()
- let parse_sexp sexp = Parser.of_sexp sexp
-
- let execute ctx ast =
- Exec.execute ctx ast
- |> Result.map (function
- | Executor.Batch {cursor_id; rows; has_more} ->
- Sublanguage_types.Cursor {cursor_id; rows; has_more}
- | Executor.Closed delta -> Sublanguage_types.Transition delta )
-end
diff --git a/lib/storable.ml b/lib/storable.ml
deleted file mode 100644
index 7c02732..0000000
--- a/lib/storable.ml
+++ /dev/null
@@ -1,125 +0,0 @@
-module Wire = struct
- let split_once ch value =
- match String.index_opt value ch with
- | None -> None
- | Some index ->
- Some
- (String.sub value 0 index, String.sub value (index + 1) (String.length value - index - 1))
-
- let lines bytes =
- bytes
- |> Bytes.to_string
- |> String.split_on_char '\n'
- |> List.filter (fun line -> String.trim line <> "")
-
- let fields bytes =
- lines bytes
- |> List.filter_map (fun line -> split_once '=' line)
- |> List.map (fun (key, value) -> String.trim key, String.trim value)
-
- let require_type expected fields =
- match List.assoc_opt "type" fields with
- | Some actual when actual = expected -> ()
- | Some actual ->
- invalid_arg (Printf.sprintf "expected storable type %S, got %S" expected actual)
- | None -> invalid_arg "missing storable type"
-
- let values key fields = List.filter_map (fun (k, v) -> if k = key then Some v else None) fields
-
- let required key fields =
- match List.assoc_opt key fields with
- | Some value -> value
- | None -> invalid_arg ("missing storable field: " ^ key)
-
- let attribute value =
- match split_once ':' value with
- | Some pair -> pair
- | None -> invalid_arg ("invalid attribute field: " ^ value)
-
- let encode fields =
- fields
- |> List.map (fun (key, value) -> key ^ "=" ^ value)
- |> String.concat "\n"
- |> fun value -> Bytes.of_string (value ^ "\n")
-end
-
-module Tuple = struct
- type t = {relation: string; attributes: (string * string) list}
-
- let to_bytes tuple =
- Wire.encode
- ( ["type", "tuple"; "relation", tuple.relation]
- @ List.map (fun (name, value) -> "attribute", name ^ ":" ^ value) tuple.attributes )
-
- let of_bytes bytes =
- let fields = Wire.fields bytes in
- Wire.require_type "tuple" fields;
- { relation= Wire.required "relation" fields;
- attributes= List.map Wire.attribute (Wire.values "attribute" fields) }
-end
-
-module Relation = struct
- type t =
- { name: string;
- schema: (string * string) list;
- (** Hex Merkle root of the relation's tuple set. Empty string = empty
- relation. *)
- tree_pointer: string }
-
- let to_bytes relation =
- Wire.encode
- ( [ "type", "relation";
- "name", relation.name;
- "kind", "stored";
- "tree_pointer", relation.tree_pointer ]
- @ List.map (fun (name, domain) -> "attribute", name ^ ":" ^ domain) relation.schema )
-
- let of_bytes bytes =
- let fields = Wire.fields bytes in
- Wire.require_type "relation" fields;
- { name= Wire.required "name" fields;
- schema= List.map Wire.attribute (Wire.values "attribute" fields);
- tree_pointer= Option.value (List.assoc_opt "tree_pointer" fields) ~default:"" }
-end
-
-module Multigroup = struct
- type t = {name: string; relations: Relation.t list}
-
- (* Wire format: "name|attr1:dom1,attr2:dom2|<merkle_root>"
- The third segment is the Merkle root hex; empty string = empty relation.
- A fourth segment for constraints is reserved but not yet implemented.
- TODO: add constraints serialisation once a canonical sexp representation
- is agreed upon (two syntactically distinct bodies may be semantically
- equivalent — the round-trip must account for that). *)
- let relation_value relation =
- let attrs =
- relation.Relation.schema
- |> List.map (fun (name, domain) -> name ^ ":" ^ domain)
- |> String.concat ","
- in
- relation.name ^ "|" ^ attrs ^ "|" ^ relation.tree_pointer
-
- let parse_relation value =
- match Wire.split_once '|' value with
- | None -> {Relation.name= value; schema= []; tree_pointer= ""}
- | Some (name, rest) ->
- let attrs_str, tree_pointer =
- match Wire.split_once '|' rest with None -> rest, "" | Some (a, tp) -> a, tp
- in
- let schema =
- if attrs_str = "" then []
- else attrs_str |> String.split_on_char ',' |> List.map Wire.attribute
- in
- {Relation.name; schema; tree_pointer}
-
- let to_bytes multigroup =
- Wire.encode
- ( ["type", "multigroup"; "name", multigroup.name]
- @ List.map (fun relation -> "relation", relation_value relation) multigroup.relations )
-
- let of_bytes bytes =
- let fields = Wire.fields bytes in
- Wire.require_type "multigroup" fields;
- { name= Wire.required "name" fields;
- relations= List.map parse_relation (Wire.values "relation" fields) }
-end
diff --git a/lib/tuple.ml b/lib/tuple.ml
deleted file mode 100644
index 1f47214..0000000
--- a/lib/tuple.ml
+++ /dev/null
@@ -1,26 +0,0 @@
-module AttributeMap = struct
- include BatMap.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]) (bindings m))
-end
-
-type non_materialized =
- { hash: Conventions.Hash.t;
- relation: Conventions.Name.t;
- attributes: Attribute.referenced AttributeMap.t (* lineage : Relation.Lineage.t option; *) }
-[@@deriving sexp_of]
-
-type materialized =
- { relation: Conventions.Name.t;
- attributes: Attribute.materialized AttributeMap.t (* lineage : Relation.Lineage.t option; *) }
-[@@deriving sexp_of]
-
-type t = Materialized of materialized | NonMaterialized of non_materialized [@@deriving sexp_of]
-
-let make_materialized ~relation ~attributes =
- Materialized {relation; attributes (* lineage = None *)}
-
-let materialized_equal a b =
- AttributeMap.equal Attribute.materialized_equal a.attributes b.attributes
diff --git a/lib/vcl/ast.ml b/lib/vcl/ast.ml
deleted file mode 100644
index ef573c0..0000000
--- a/lib/vcl/ast.ml
+++ /dev/null
@@ -1 +0,0 @@
-type statement = Use of string
diff --git a/lib/vcl/executor.ml b/lib/vcl/executor.ml
deleted file mode 100644
index ff95583..0000000
--- a/lib/vcl/executor.ml
+++ /dev/null
@@ -1,9 +0,0 @@
-module Make (NT : Nt.S) = struct
- let execute (ctx : Sublanguage_context.t) (stmt : Ast.statement) :
- (Sublanguage_types.result, Condition.t) result =
- match stmt with
- | Ast.Use branch_name ->
- Result.map (fun delta -> Sublanguage_types.Transition delta) (ctx.switch_branch branch_name)
-
- let _ = (module NT : Nt.S)
-end
diff --git a/lib/vcl/sublanguage.ml b/lib/vcl/sublanguage.ml
deleted file mode 100644
index 437c93b..0000000
--- a/lib/vcl/sublanguage.ml
+++ /dev/null
@@ -1,22 +0,0 @@
-module Make (NT : Nt.S) = struct
- module Error = struct
- open Condition
-
- let unrecognized_command expr =
- condition "unrecognized-command" "Unrecognized command" ("expression" |=| of_sexp expr)
- end
-
- module Exec = Executor.Make (NT)
-
- type configuration = unit
- type ast = Ast.statement
-
- let name = "vcl"
- let parse _ = Ok ()
-
- let parse_sexp = function
- | Sexplib.Sexp.(List [Atom "use"; Atom branch]) -> Ok (Ast.Use branch)
- | sexp -> Error (Error.unrecognized_command sexp)
-
- let execute = Exec.execute
-end