aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--bin/server.ml119
-rw-r--r--docs/dcl.org105
-rw-r--r--docs/icl-quantification.org (renamed from docs/dcl-quantification.org)4
-rw-r--r--docs/icl.org108
-rw-r--r--docs/karuta-integration.org26
-rw-r--r--docs/n-way-binding.org8
-rw-r--r--lib/dcl/ast.ml24
-rw-r--r--lib/dcl/executor.ml126
-rw-r--r--lib/dcl/parser.ml8
-rw-r--r--lib/icl/ast.ml23
-rw-r--r--lib/icl/executor.ml50
-rw-r--r--lib/icl/parser.ml9
-rw-r--r--lib/management/branch.ml138
-rw-r--r--lib/management/diff.ml60
-rw-r--r--lib/management/merge.ml235
-rw-r--r--lib/manipulation.ml2
-rw-r--r--lib/prelude/catalog.ml3
-rw-r--r--test/test_relational_engine.ml296
18 files changed, 1223 insertions, 121 deletions
diff --git a/bin/server.ml b/bin/server.ml
index e669489..2c84468 100644
--- a/bin/server.ml
+++ b/bin/server.ml
@@ -34,13 +34,20 @@ let materialize_relation storage (rel : Relation.t) limit =
let short_hash (h : string) = String.sub h 0 (min 8 (String.length h))
+module BranchOps = Management.Branch.Make(Management.Physical.Memory)
+
+let get_branch storage =
+ match BranchOps.get_head storage with
+ | Ok (Some name) -> name
+ | _ -> "--"
+
let tuple_to_sexp (t : Tuple.materialized) =
let open Sexplib.Sexp in
List (Tuple.AttributeMap.bindings t.Tuple.attributes
|> List.map (fun (k, attr) ->
List [Atom k; Conventions.AbstractValue.sexp_of_t attr.Attribute.value]))
-let relation_to_sexp storage (db_hash : string) (rel : Relation.t) limit =
+let relation_to_sexp storage db_name db_hash (rel : Relation.t) limit =
let open Sexplib.Sexp in
let schema_sexp =
List (List.map (fun (a, d) -> List [Atom a; Atom d]) rel.Relation.schema)
@@ -55,22 +62,28 @@ let relation_to_sexp storage (db_hash : string) (rel : Relation.t) limit =
List [Atom "row_count"; Atom (string_of_int (List.length tuples))];
List [Atom "truncated"; Atom (string_of_bool truncated)];
List [Atom "db_hash"; Atom (short_hash db_hash)];
+ List [Atom "db_name"; Atom db_name];
+ List [Atom "branch"; Atom (get_branch storage)];
]
-let ok_response db_hash msg =
+let ok_response storage db_name db_hash msg =
let open Sexplib.Sexp in
to_string @@ List [
Atom "ok";
List [Atom "message"; Atom msg];
List [Atom "db_hash"; Atom (short_hash db_hash)];
+ List [Atom "db_name"; Atom db_name];
+ List [Atom "branch"; Atom (get_branch storage)];
]
-let error_response db_hash msg =
+let error_response storage db_name db_hash msg =
let open Sexplib.Sexp in
to_string @@ List [
Atom "error";
List [Atom "message"; Atom msg];
List [Atom "db_hash"; Atom (short_hash db_hash)];
+ List [Atom "db_name"; Atom db_name];
+ List [Atom "branch"; Atom (get_branch storage)];
]
let manip_err = function
@@ -85,9 +98,18 @@ let manip_err = function
a valid DRL expression that happens to also parse as DML would silently
be treated as DRL. The three sublanguages should share a common envelope,
e.g. a top-level tag distinguishing (Query ...) from (Exec ...). *)
+let advance_head_branch storage new_hash =
+ match BranchOps.get_head storage with
+ | Ok (Some branch_name) ->
+ ignore (BranchOps.update_tip storage ~name:branch_name ~tip:new_hash)
+ | _ -> ()
+
let execute_command storage db_ref cmd =
- let db = !db_ref in
- let h = db.Management.Database.hash in
+ let db = !db_ref in
+ let h = db.Management.Database.hash in
+ let name = db.Management.Database.name in
+ let ok = ok_response storage name in
+ let err = error_response storage name in
(* TODO: (schema) is a stopgap. Introspection should be expressible in
DRL itself via the catalog relations, not special-cased here. *)
let cmd = match String.trim cmd with
@@ -97,39 +119,53 @@ let execute_command storage db_ref cmd =
match Drl.Parser.of_string cmd with
| Ok query ->
(match Drl.Executor.Memory.execute storage db query with
- | Ok rel -> relation_to_sexp storage h rel default_limit
+ | Ok rel -> relation_to_sexp storage name h rel default_limit
| Error (Drl.Executor.Memory.RelationNotFound s) ->
- error_response h ("RelationNotFound: " ^ s)
+ err h ("RelationNotFound: " ^ s)
| Error (Drl.Executor.Memory.AlgebraError (Algebra.StorageError s)) ->
- error_response h ("StorageError: " ^ s)
+ err h ("StorageError: " ^ s)
| Error (Drl.Executor.Memory.AlgebraError (Algebra.GeneratorError s)) ->
- error_response h ("GeneratorError: " ^ s))
+ err h ("GeneratorError: " ^ s))
| Error _ ->
match Dml.Parser.of_string cmd with
| Ok stmt ->
(match Dml.Executor.Memory.execute storage db stmt with
| Ok new_db ->
db_ref := new_db;
- ok_response new_db.Management.Database.hash "Database updated"
+ advance_head_branch storage new_db.Management.Database.hash;
+ ok new_db.Management.Database.hash "updated"
| Error (Dml.Executor.Memory.ManipulationError me) ->
- error_response h (manip_err me)
+ err h (manip_err me)
| Error (Dml.Executor.Memory.RelationNotFound s) ->
- error_response h ("RelationNotFound: " ^ s)
+ err h ("RelationNotFound: " ^ s)
| Error (Dml.Executor.Memory.ParseError s) ->
- error_response h ("ParseError: " ^ s))
+ err h ("ParseError: " ^ s))
| Error _ ->
- match Dcl.Parser.of_string cmd with
+ match Icl.Parser.of_string cmd with
| Ok stmt ->
- (match Dcl.Executor.Memory.execute storage db stmt with
- | Ok new_db ->
+ (match Icl.Executor.Memory.execute storage db stmt with
+ | Ok (new_db, msg) ->
db_ref := new_db;
- ok_response new_db.Management.Database.hash "Constraint registered"
- | Error (Dcl.Executor.Memory.ManipulationError me) ->
- error_response h (manip_err me)
- | Error (Dcl.Executor.Memory.ConversionError s) ->
- error_response h ("ConversionError: " ^ s))
+ advance_head_branch storage new_db.Management.Database.hash;
+ ok new_db.Management.Database.hash msg
+ | Error (Icl.Executor.Memory.ManipulationError me) ->
+ err h (manip_err me)
+ | Error (Icl.Executor.Memory.ConversionError s) ->
+ err h ("ConversionError: " ^ s))
| Error _ ->
- error_response h "Parse error: not valid DRL, DML, or DCL"
+ match Dcl.Parser.of_string cmd with
+ | Ok stmt ->
+ (match Dcl.Executor.Memory.execute storage db stmt with
+ | Ok (new_db, msg) ->
+ db_ref := new_db;
+ advance_head_branch storage new_db.Management.Database.hash;
+ ok new_db.Management.Database.hash msg
+ | Error (Dcl.Executor.Memory.BranchError s) ->
+ err h ("BranchError: " ^ s)
+ | Error (Dcl.Executor.Memory.MergeError s) ->
+ err h ("MergeError: " ^ s))
+ | Error _ ->
+ err h "ParseError: not valid DRL, DML, ICL, or DCL"
(* TODO: registration failures are silently ignored; a broken prelude
relation leaves the catalog in a partially-seeded state with no
@@ -146,7 +182,10 @@ let register_prelude_relations storage db =
~cardinality:rel.cardinality
with
| Ok (new_db, _) -> new_db
- | Error _ -> db)
+ | Error e ->
+ Printf.eprintf "Warning: failed to register prelude relation %s: %s\n%!"
+ rel.name (manip_err e);
+ db)
db
[ less_than_natural
; less_than_or_equal_natural
@@ -174,7 +213,8 @@ let handle_client storage db_ref fd =
try execute_command storage db_ref line
with e ->
let db = !db_ref in
- error_response db.Management.Database.hash
+ error_response storage db.Management.Database.name
+ db.Management.Database.hash
("Uncaught error: " ^ Printexc.to_string e)
in
output_string oc (response ^ "\n");
@@ -311,6 +351,37 @@ let () =
| Error _ -> failwith "Failed to create initial database"
| Ok db ->
let db = register_prelude_relations storage db in
+ (* Register ephemeral sakura:branch and sakura:head relations backed by
+ the raw branch registry — no stored tuples, no circularity. *)
+ let db =
+ let register db rel =
+ match Manipulation.Memory.create_immutable_relation storage db
+ ~name:rel.Relation.name
+ ~schema:rel.Relation.schema
+ ~generator:(Option.get rel.Relation.generator)
+ ~membership_criteria:rel.Relation.membership_criteria
+ ~cardinality:rel.Relation.cardinality
+ with
+ | Ok (db, _) -> db
+ | Error e ->
+ Printf.eprintf "Warning: failed to register %s: %s\n%!"
+ rel.Relation.name (match e with
+ | Manipulation.RelationAlreadyExists s -> "already exists: " ^ s
+ | Manipulation.StorageError s -> s | _ -> "error");
+ db
+ in
+ let db = register db (BranchOps.branch_relation storage) in
+ let db = register db (BranchOps.head_relation storage) in
+ db
+ in
+ (* Create default master branch in raw registry and set HEAD *)
+ (match BranchOps.create storage ~name:"master"
+ ~tip:db.Management.Database.hash with
+ | Error e -> Printf.eprintf "Warning: failed to create master branch: %s\n%!" e
+ | Ok () -> ());
+ (match BranchOps.checkout storage "master" with
+ | Error e -> Printf.eprintf "Warning: failed to checkout master: %s\n%!" e
+ | Ok () -> ());
let db_ref = ref db in
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
Unix.setsockopt sock Unix.SO_REUSEADDR true;
diff --git a/docs/dcl.org b/docs/dcl.org
new file mode 100644
index 0000000..92fc19d
--- /dev/null
+++ b/docs/dcl.org
@@ -0,0 +1,105 @@
+#+TITLE: DCL — Database Control Language
+
+DCL manages branches: named pointers to database states. It provides
+Git-like operations built on Sakura's append-only, content-addressed
+storage. Every mutation automatically advances the current branch tip,
+so you never need to track hashes manually.
+
+* Syntax reference
+
+| Command | Effect |
+|--------------------------------------------+--------------------------------------|
+| ~(CreateBranch (name N))~ | Create branch N at current state |
+| ~(CreateBranch (name N) (hash H))~ | Create branch N at a specific hash |
+| ~(Checkout N)~ | Switch to branch N, restore its db |
+| ~(GetHead)~ | Print the current HEAD branch name |
+| ~(GetBranchTip N)~ | Print the stored hash of branch N |
+| ~(UpdateBranchTip (name N) (hash H))~ | Manually advance branch N to hash H |
+| ~(Merge (left L) (right R) (strategy S))~ | 3-way merge branch R into L |
+
+Branch state is always queryable as relations:
+
+#+begin_src sexp
+(Base sakura:branch) ; name × hash for every branch
+(Base sakura:head) ; single-tuple: current branch name
+#+end_src
+
+Merge strategies:
+
+| Strategy | Behaviour on conflict |
+|--------------------+----------------------------------------------|
+| ~PreferLeft~ | Keep the left branch's version |
+| ~PreferRight~ | Keep the right branch's version |
+| ~RevertToAncestor~ | Revert conflicting relation to the LCA state |
+
+* Example: travelling through history
+
+#+begin_src sexp
+(CreateRelation (name "scores") (schema ((player "string") (pts "integer"))))
+
+(CreateBranch (name "v0"))
+
+(InsertTuple (relation "scores") (attributes ((player (Str "Alice")) (pts (Int 10)))))
+
+(CreateBranch (name "v1"))
+
+(InsertTuple (relation "scores") (attributes ((player (Str "Bob")) (pts (Int 25)))))
+
+(CreateBranch (name "v2"))
+#+end_src
+
+Now jump around and watch the relation change:
+
+#+begin_src sexp
+(Checkout "v0")
+(Base scores)
+; (0 rows)
+
+(Checkout "v1")
+(Base scores)
+; ┌────────┬─────┐
+; │ player │ pts │
+; ├────────┼─────┤
+; │ Alice │ 10 │
+; └────────┴─────┘
+
+(Checkout "v2")
+(Base scores)
+; ┌────────┬─────┐
+; │ player │ pts │
+; ├────────┼─────┤
+; │ Alice │ 10 │
+; │ Bob │ 25 │
+; └────────┴─────┘
+#+end_src
+
+* Example: diverge and merge
+
+#+begin_src sexp
+(Checkout "master")
+(CreateBranch (name "feature"))
+
+(Checkout "master")
+(InsertTuple (relation "users") (attributes ((id (Int 1)) (name (Str "Alice")))))
+
+(Checkout "feature")
+(InsertTuple (relation "users") (attributes ((id (Int 2)) (name (Str "Bob")))))
+
+(Merge (left "master") (right "feature") (strategy PreferLeft))
+
+(Checkout "master")
+(Base users)
+; ┌────┬───────┐
+; │ id │ name │
+; ├────┼───────┤
+; │ 1 │ Alice │
+; │ 2 │ Bob │
+; └────┴───────┘
+#+end_src
+
+* See also
+
+- ~lib/dcl/~ — AST, parser, executor
+- ~lib/management/branch.ml~ — branch registry and ephemeral relations
+- ~lib/management/merge.ml~ — 3-way merge engine
+- ~lib/management/diff.ml~ — relation diff used internally by merge
diff --git a/docs/dcl-quantification.org b/docs/icl-quantification.org
index 81e9cad..7a81551 100644
--- a/docs/dcl-quantification.org
+++ b/docs/icl-quantification.org
@@ -1,8 +1,8 @@
-#+TITLE: DCL Quantification: Runtime Model and Evaluation
+#+TITLE: ICL Quantification: Runtime Model and Evaluation
* Overview
-This document describes precisely how DCL constraints are represented, compiled,
+This document describes precisely how ICL constraints are represented, compiled,
and evaluated at runtime. It covers the full stack from the s-expression syntax
through AST compilation, context construction, and recursive evaluation — with
particular attention to the cost model of quantifiers, which is the primary target
diff --git a/docs/icl.org b/docs/icl.org
new file mode 100644
index 0000000..c2258bf
--- /dev/null
+++ b/docs/icl.org
@@ -0,0 +1,108 @@
+#+TITLE: ICL — Integrity Control Language
+
+ICL registers integrity constraints on relations. A constraint is a
+membership check: before any tuple is inserted, Sakura verifies that
+the tuple belongs to every constraint-relation attached to the target
+relation.
+
+Constraints are expressed as S-expressions and sent over the wire like
+any other command.
+
+* Syntax
+
+#+begin_src
+(RegisterConstraint
+ (constraint_name "<name>")
+ (relation_name "<target-relation>")
+ (body <constraint-body>))
+#+end_src
+
+A ~<constraint-body>~ is one of:
+
+| Form | Meaning |
+|-------------------------------------------------+--------------------------------|
+| ~(MemberOf (target R) (binding (...)))~ | Tuple must be in relation R |
+| ~(Not (body B) (universe R))~ | Negation (closed-world over R) |
+| ~(And (B1 B2 ...))~ | All must hold |
+| ~(Or (B1 B2 ...))~ | At least one must hold |
+| ~(Exists (variable v) (quantifier R) (body B))~ | ∃ v ∈ R such that B holds |
+| ~(Forall (variable v) (quantifier R) (body B))~ | ∀ v ∈ R, B holds |
+
+Bindings map target-relation attribute names to values drawn from the
+tuple being checked:
+
+| Binding expr | Meaning |
+|---------------------+--------------------------------|
+| ~(Var "attr")~ | Value of ~attr~ from the tuple |
+| ~(Const (Int N))~ | Literal integer N |
+| ~(Const (Str "s"))~ | Literal string s |
+| ~(Const (Float f))~ | Literal float f |
+
+* Examples
+
+** Foreign key
+
+#+begin_src sexp
+(CreateRelation (name "Department") (schema ((dept_id "integer") (dept_name "string"))))
+(CreateRelation (name "Employee") (schema ((emp_id "integer") (emp_name "string") (dept_id "integer"))))
+
+(RegisterConstraint
+ (constraint_name "fk_employee_dept")
+ (relation_name "Employee")
+ (body (MemberOf
+ (target "Department")
+ (binding ((dept_id (Var "dept_id")))))))
+#+end_src
+
+** Range check
+
+#+begin_src sexp
+(CreateRelation (name "Result") (schema ((student_id "integer") (score "integer"))))
+
+(RegisterConstraint
+ (constraint_name "score_range")
+ (relation_name "Result")
+ (body (And
+ ((MemberOf (target "greater_than_or_equal_natural")
+ (binding ((left (Var "score")) (right (Const (Int 0))))))
+ (MemberOf (target "less_than_or_equal_natural")
+ (binding ((left (Var "score")) (right (Const (Int 100))))))))))
+#+end_src
+
+** Existential (FK through a join)
+
+A ~Suite~ is only valid if its room belongs to a building with more
+than 3 floors:
+
+#+begin_src sexp
+(CreateRelation (name "Building") (schema ((building_id "integer") (building_name "string") (floors "integer"))))
+(CreateRelation (name "Room") (schema ((room_id "integer") (building_id "integer") (floor "integer"))))
+(CreateRelation (name "Suite") (schema ((suite_id "integer") (room_id "integer") (suite_name "string"))))
+
+(RegisterConstraint
+ (constraint_name "suite_in_tall_building")
+ (relation_name "Suite")
+ (body
+ (Exists (variable "r") (quantifier "Room")
+ (body
+ (Exists (variable "b") (quantifier "Building")
+ (body
+ (And
+ ((MemberOf (target "Room")
+ (binding ((room_id (Var "room_id")))))
+ (MemberOf (target "Building")
+ (binding ((building_id (Var "r.building_id")))))
+ (MemberOf (target "greater_than_natural")
+ (binding ((left (Var "b.floors"))
+ (right (Const (Int 3))))))))))))))
+#+end_src
+
+Note: quantifier variables are namespaced — attributes from variable
+~r~ are accessed as ~r.attr_name~ inside nested scopes.
+
+* See also
+
+- ~lib/icl/~ — AST, parser, executor
+- ~lib/constraint.ml~ — runtime constraint representation and evaluator
+- ~docs/icl-quantification.org~ — full runtime model for ~Exists~/~Forall~
+- ~docs/constraints.org~ — conceptual background
diff --git a/docs/karuta-integration.org b/docs/karuta-integration.org
index a144a25..0642254 100644
--- a/docs/karuta-integration.org
+++ b/docs/karuta-integration.org
@@ -14,10 +14,26 @@ Here's an overview of the sublanguages and how they are manifested in Karuta:
- Pure querying, total/terminating subset;
- No user recursion with no self references.
-** DCL (Data Constraint Language)
+** ICL (Integrity Control Language)
- Integrity rules (key, FK-like, checks, assertions, aggregates-for-integrity).
- Semantically predicates, but with enforcement timing (on write/commit), not free query operators.
+- Implemented in =lib/icl/= (=Ast=, =Parser=, =Executor=).
+
+** DCL (Database Control Language)
+
+- Branch management: create/checkout branches, query HEAD and tip hashes.
+- Merge: 3-way merge of two branch tips with configurable conflict strategy (=PreferLeft=, =PreferRight=, =RevertToAncestor=).
+- Implemented in =lib/dcl/= (=Ast=, =Parser=, =Executor=).
+- Example commands:
+ #+begin_src sexp
+ (CreateBranch (name "feature") (tip "<hash>"))
+ (Checkout "feature")
+ (GetHead)
+ (GetBranchTip "main")
+ (UpdateBranchTip (name "main") (tip "<hash>"))
+ (Merge (left "main") (right "feature") (strategy PreferLeft))
+ #+end_src
** DML (Data Manipulation Language)
@@ -35,7 +51,7 @@ Here's an overview of the sublanguages and how they are manifested in Karuta:
** PPL (Procedural Predicate Language)
- Stored procedures/functions, recursion allowed, orchestration logic.
-- Can call DRL/DML/DCL-aware operations, but not all PPL predicates are DRL-safe.
+- Can call DRL/DML/ICL/DCL-aware operations, but not all PPL predicates are DRL-safe.
** ACL (Authorization/Policy Language) (optional early, important later)
@@ -62,21 +78,21 @@ Here's an overview of the sublanguages and how they are manifested in Karuta:
person[string, natural] :: sakura:persisted
person[Name, Age] :- valid_age[Age].
- % DCL
+ % ICL
another-constraint[list[person], string, natural] :: sakura:constraint
another-constraint[[], _, _].
another-constraint[[person[Name, Age]|Rest], Whatever1, Whatever2] :-
(eq[Name, Whatever1] ; !eq[Name, Whatever1], !eq[Age, Whatever2]),
another-constraint[Rest, Whatever1, Whatever2].
- % DCL
+ % ICL
my-predicate[int, string, nat] :: sakura:constraint
my-predicate[Arg1, Arg2, Arg3] :-
another-module:my-predicate[Arg1, Arg2, Arg3],
on[insert, update],
timing[immediate].
- % DCL
+ % ICL
valid_age/1 :: sakura:constraint
valid_age[Age] with [karuta, sakura] :-
nat[Age],
diff --git a/docs/n-way-binding.org b/docs/n-way-binding.org
index 39c9d65..85dc0e3 100644
--- a/docs/n-way-binding.org
+++ b/docs/n-way-binding.org
@@ -1,9 +1,9 @@
-#+TITLE: N-Way Binding in DCL Constraints
+#+TITLE: N-Way Binding in ICL Constraints
#+DATE: 2026-03-11
* Overview
-The DCL constraint language supports quantified membership checks via ~Exists~ and ~Forall~.
+The ICL constraint language supports quantified membership checks via ~Exists~ and ~Forall~.
This document illustrates the hotel/building/room/suite example to motivate n-ary quantification
and show how 3-wise (and deeper) relational composition is expressed.
@@ -72,7 +72,7 @@ to fire when suites referencing its rooms are inserted.
((suite_id (Int 1003)) (room_id (Int 102)) (suite_name (Str "Deluxe")) (capacity (Int 3))))))
#+end_src
-* DCL — Constraints
+* ICL — Constraints
Binary FK constraints compose to enforce referential integrity along the chain
~Suite → Room → Building~. Each link is declared independently.
@@ -202,5 +202,5 @@ bound to variable ~x~.
Without namespacing, ~extend_tuple~ would overwrite the incoming tuple's attributes
with same-named attributes from the quantifier row, silently making ~Var~ resolve to
-the wrong scope. See ~lib/constraint.ml~ and ~docs/dcl-quantification.org~ for a full
+the wrong scope. See ~lib/constraint.ml~ and ~docs/icl-quantification.org~ for a full
account of this failure mode and the provenance TODO.
diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml
index 95e0271..e1dae13 100644
--- a/lib/dcl/ast.ml
+++ b/lib/dcl/ast.ml
@@ -1,23 +1,13 @@
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 }
+type merge_strategy = PreferLeft | PreferRight | RevertToAncestor
[@@deriving sexp]
type statement =
- | RegisterConstraint of {
- constraint_name: string;
- relation_name: string;
- body: constraint_body;
- }
+ | CreateBranch of { name: string; hash: string option [@sexp.option] }
+ | Checkout of string
+ | GetHead
+ | GetBranchTip of string
+ | UpdateBranchTip of { name: string; hash: string }
+ | Merge of { left: string; right: string; strategy: merge_strategy }
[@@deriving sexp]
diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml
index 810781f..bf549ec 100644
--- a/lib/dcl/executor.ml
+++ b/lib/dcl/executor.ml
@@ -1,54 +1,94 @@
-module Make (Storage : Management.Physical.S) = struct
- module Ops = Manipulation.Make(Storage)
+module Make (Storage : Management.Physical.S with type error = string) = struct
+ module Ops = Manipulation.Make(Storage)
+ module Branch = Management.Branch.Make(Storage)
+ module MergeOps = Management.Merge.Make(Storage)(Ops)
type error =
- | ManipulationError of Manipulation.error
- | ConversionError of string
-
- let wrap_manip = Result.map_error (fun e -> ManipulationError e)
-
- (** Convert a DCL binding_expr to a runtime Constraint.binding_expr *)
- 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)
-
- (** Convert a list of (target_attr, binding_expr) pairs to a Constraint.binding (BindingMap) *)
- 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
-
- (** Convert a DCL constraint_body AST to a runtime Constraint.t *)
- let rec convert_body : Ast.constraint_body -> Constraint.t = function
- | Ast.MemberOf { target; binding } ->
- Constraint.MemberOf { target; binding = convert_binding binding }
- | Ast.Not { body; universe } ->
- Constraint.Not { body = convert_body body; universe }
- | 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; body = convert_body body }
- | Ast.Forall { variable; quantifier; body } ->
- Constraint.Forall { variable; quantifier; body = convert_body body }
+ | BranchError of string
+ | MergeError of string
+
+ let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = function
+ | Ast.PreferLeft -> Management.Merge.PreferLeft
+ | Ast.PreferRight -> Management.Merge.PreferRight
+ | Ast.RevertToAncestor -> Management.Merge.RevertToAncestor
+
+ let manip_err = function
+ | Manipulation.RelationNotFound s -> "RelationNotFound: " ^ s
+ | Manipulation.RelationAlreadyExists s -> "RelationAlreadyExists: " ^ s
+ | Manipulation.TupleNotFound h -> "TupleNotFound: " ^ h
+ | Manipulation.DuplicateTuple h -> "DuplicateTuple: " ^ h
+ | Manipulation.ConstraintViolation s -> "ConstraintViolation: " ^ s
+ | Manipulation.StorageError s -> "StorageError: " ^ s
let execute
(storage : Storage.t)
(db : Management.Database.t)
(stmt : Ast.statement)
- : (Management.Database.t, error) result =
+ : (Management.Database.t * string, error) result =
match stmt with
- | Ast.RegisterConstraint { constraint_name; relation_name; body } ->
- (* TODO: Additional constraint operations (drop constraint, list constraints,
- validate existing tuples against new constraint) are not supported via DCL.
- Use the OCaml API for these advanced operations. *)
- let runtime_body = convert_body body in
- Ops.register_constraint storage db
- ~constraint_name ~relation_name ~body:runtime_body
- |> wrap_manip
+
+ | Ast.CreateBranch { name; hash } ->
+ let tip = match hash with
+ | Some h -> h
+ | None -> db.Management.Database.hash
+ in
+ (match Branch.create storage ~name ~tip with
+ | Error e -> Error (BranchError e)
+ | Ok () -> Ok (db, "Branch " ^ name ^ " created"))
+
+ | Ast.Checkout branch_name ->
+ (match Branch.get_tip storage branch_name with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name))
+ | Ok (Some tip) ->
+ (match Branch.checkout storage branch_name with
+ | Error e -> Error (BranchError e)
+ | Ok () ->
+ (match Ops.load_database storage tip with
+ | Error e -> Error (BranchError (manip_err e))
+ | Ok None -> Error (BranchError ("No database at hash: " ^ tip))
+ | Ok (Some loaded_db) ->
+ Ok (loaded_db, "HEAD:" ^ branch_name))))
+
+ | Ast.GetHead ->
+ (match Branch.get_head storage with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Ok (db, "HEAD is unset")
+ | Ok (Some name) -> Ok (db, "HEAD:" ^ name))
+
+ | Ast.GetBranchTip name ->
+ (match Branch.get_tip storage name with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Error (BranchError ("Branch not found: " ^ name))
+ | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash))
+
+ | Ast.UpdateBranchTip { name; hash } ->
+ (match Branch.update_tip storage ~name ~tip:hash with
+ | Error e -> Error (BranchError e)
+ | Ok () -> Ok (db, "Branch " ^ name ^ " updated"))
+
+ | Ast.Merge { left; right; strategy } ->
+ (match Branch.get_tip storage left, Branch.get_tip storage right with
+ | Error e, _ | _, Error e -> Error (BranchError e)
+ | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left))
+ | _, Ok None -> Error (BranchError ("Branch not found: " ^ right))
+ | Ok (Some left_tip), Ok (Some right_tip) ->
+ let strat = convert_strategy strategy in
+ (match MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip with
+ | Error e -> Error (MergeError (manip_err e))
+ | Ok (Management.Merge.Failed conflicts) ->
+ let msgs = List.map (function
+ | Management.Merge.TupleConflict { relation; hash } ->
+ "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
+ | Management.Merge.SchemaConflict r -> "schema conflict in " ^ r
+ | Management.Merge.ConstraintConflict r -> "constraint conflict in " ^ r
+ ) conflicts in
+ Error (MergeError ("Merge failed: " ^ String.concat "; " msgs))
+ | Ok (Management.Merge.Clean merged_db) ->
+ let _ = Branch.update_tip storage ~name:left
+ ~tip:merged_db.Management.Database.hash in
+ Ok (merged_db,
+ "Merged:" ^ right ^ "→" ^ left)))
end
module Memory = Make(Management.Physical.Memory)
diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml
index a7981c0..3caf748 100644
--- a/lib/dcl/parser.ml
+++ b/lib/dcl/parser.ml
@@ -1,7 +1,13 @@
type error = ParseError of string
let of_string s =
- match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
+ (* ppx_sexp_conv encodes no-argument variants as bare atoms, so
+ unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *)
+ let sexp = match Sexplib.Sexp.of_string s with
+ | Sexplib.Sexp.List [atom] -> atom
+ | other -> other
+ in
+ match Ast.statement_of_sexp sexp with
| stmt -> Ok stmt
| exception exn -> Error (ParseError (Printexc.to_string exn))
diff --git a/lib/icl/ast.ml b/lib/icl/ast.ml
new file mode 100644
index 0000000..95e0271
--- /dev/null
+++ b/lib/icl/ast.ml
@@ -0,0 +1,23 @@
+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
new file mode 100644
index 0000000..a895135
--- /dev/null
+++ b/lib/icl/executor.ml
@@ -0,0 +1,50 @@
+module Make (Storage : Management.Physical.S) = struct
+ module Ops = Manipulation.Make(Storage)
+
+ type error =
+ | ManipulationError of Manipulation.error
+ | ConversionError of string
+
+ let wrap_manip = Result.map_error (fun e -> ManipulationError e)
+
+ 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.MemberOf { target; binding = convert_binding binding }
+ | Ast.Not { body; universe } ->
+ Constraint.Not { body = convert_body body; universe }
+ | 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; body = convert_body body }
+ | Ast.Forall { variable; quantifier; body } ->
+ Constraint.Forall { variable; quantifier; body = convert_body body }
+
+ let execute
+ (storage : Storage.t)
+ (db : Management.Database.t)
+ (stmt : Ast.statement)
+ : (Management.Database.t * string, error) result =
+ match stmt with
+ | Ast.RegisterConstraint { constraint_name; relation_name; body } ->
+ let runtime_body = convert_body body in
+ (match Ops.register_constraint storage db
+ ~constraint_name ~relation_name ~body:runtime_body
+ |> wrap_manip with
+ | Ok new_db -> Ok (new_db, "Constraint registered: " ^ constraint_name)
+ | Error e -> Error e)
+end
+
+module Memory = Make(Management.Physical.Memory)
diff --git a/lib/icl/parser.ml b/lib/icl/parser.ml
new file mode 100644
index 0000000..a7981c0
--- /dev/null
+++ b/lib/icl/parser.ml
@@ -0,0 +1,9 @@
+type error = ParseError of string
+
+let of_string s =
+ match Sexplib.Sexp.of_string s |> Ast.statement_of_sexp with
+ | stmt -> Ok stmt
+ | exception exn -> Error (ParseError (Printexc.to_string exn))
+
+let to_string stmt =
+ Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/management/branch.ml b/lib/management/branch.ml
new file mode 100644
index 0000000..70dfd85
--- /dev/null
+++ b/lib/management/branch.ml
@@ -0,0 +1,138 @@
+(** 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 with type error = string) = struct
+
+ let load_names storage =
+ match Storage.load_raw storage names_key with
+ | Ok (Some bytes) -> (Marshal.from_bytes bytes 0 : string list)
+ | _ -> []
+
+ 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 ("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 sakura:branch"
+ | Some pos ->
+ (match list storage with
+ | Error _ -> Generator.Done
+ | Ok branches ->
+ if pos >= List.length branches then Generator.Done
+ else
+ let (name, tip) = List.nth branches pos in
+ let short = String.sub tip 0 (min 8 (String.length tip)) in
+ let attributes =
+ Tuple.AttributeMap.of_list
+ [ ("name", mk name)
+ ; ("hash", mk short)
+ ]
+ in
+ Generator.Value
+ ( Tuple.make_materialized ~relation:Prelude.Catalog.branch_rel_name ~attributes
+ , generator ))
+ 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 sakura:head"
+ | Some 0 ->
+ (match get_head storage with
+ | Ok None | Error _ -> Generator.Done
+ | Ok (Some branch_name) ->
+ let attributes =
+ Tuple.AttributeMap.of_list [ ("branch", mk branch_name) ]
+ in
+ Generator.Value
+ ( Tuple.make_materialized ~relation:Prelude.Catalog.head_rel_name ~attributes
+ , fun _ -> Generator.Done ))
+ | Some _ -> 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/diff.ml b/lib/management/diff.ml
new file mode 100644
index 0000000..865c757
--- /dev/null
+++ b/lib/management/diff.ml
@@ -0,0 +1,60 @@
+(** Structural delta between two Database.t states.
+ Computes what changed from ancestor → target at the relation level. *)
+
+type relation_diff =
+ | RelationAdded of Relation.t
+ | RelationRemoved of string
+ | RelationModified of {
+ name : string;
+ added_tuples : Conventions.Hash.t list;
+ removed_tuples : Conventions.Hash.t list;
+ schema_changed : bool;
+ }
+
+type t = {
+ ancestor : Conventions.Hash.t;
+ left : Conventions.Hash.t;
+ right : Conventions.Hash.t;
+ relation_diffs : relation_diff list;
+}
+
+module StringSet = Set.Make(String)
+
+let relation_keys rel =
+ match rel.Relation.tree with
+ | None -> StringSet.empty
+ | Some tree -> StringSet.of_list (Merkle.keys tree)
+
+(** Compute relation-level diffs from ancestor → target. *)
+let diff ~ancestor ~(target : Database.t) =
+ let ancestor_names =
+ Database.get_relation_names ancestor |> StringSet.of_list
+ in
+ let target_names =
+ Database.get_relation_names target |> StringSet.of_list
+ in
+ let all_names = StringSet.union ancestor_names target_names in
+ StringSet.fold (fun name acc ->
+ let in_ancestor = StringSet.mem name ancestor_names in
+ let in_target = StringSet.mem name target_names in
+ match in_ancestor, in_target with
+ | false, true ->
+ let rel = Option.get (Database.get_relation target name) in
+ RelationAdded rel :: acc
+ | true, false ->
+ RelationRemoved name :: acc
+ | true, true ->
+ let anc_rel = Option.get (Database.get_relation ancestor name) in
+ let tgt_rel = Option.get (Database.get_relation target name) in
+ (* Compare hashes — if identical, no diff *)
+ if anc_rel.Relation.hash = tgt_rel.Relation.hash then acc
+ else begin
+ let anc_keys = relation_keys anc_rel in
+ let tgt_keys = relation_keys tgt_rel in
+ let added_tuples = StringSet.diff tgt_keys anc_keys |> StringSet.elements in
+ let removed_tuples = StringSet.diff anc_keys tgt_keys |> StringSet.elements in
+ let schema_changed = anc_rel.Relation.schema <> tgt_rel.Relation.schema in
+ RelationModified { name; added_tuples; removed_tuples; schema_changed } :: acc
+ end
+ | false, false -> acc (* impossible *)
+ ) all_names []
diff --git a/lib/management/merge.ml b/lib/management/merge.ml
new file mode 100644
index 0000000..e50d0e6
--- /dev/null
+++ b/lib/management/merge.ml
@@ -0,0 +1,235 @@
+(** 3-way merge of two branch tips using their Lowest Common Ancestor.
+ Walks the history chain to find it, diffs both sides against it,
+ applies merge rules, validates constraints, and persists the result. *)
+
+type conflict =
+ | TupleConflict of { relation: string; hash: Conventions.Hash.t }
+ | SchemaConflict of string
+ | ConstraintConflict of string
+
+type strategy = PreferLeft | PreferRight | RevertToAncestor
+
+type merge_result =
+ | Clean of Database.t
+ | Failed of conflict list
+
+(** Module type for the subset of Manipulation.Make we need. *)
+module type MANIPULATION = sig
+ type storage
+ type error
+ val of_string_error : string -> error
+ val load_database : storage -> Conventions.Hash.t -> (Database.t option, error) result
+ val store_database : storage -> Database.t -> (unit, error) result
+end
+
+module StringSet = Set.Make(String)
+
+(** Walk history to find LCA. First hash in right's ancestry that also appears
+ in left's ancestry set. *)
+let find_lca left_db right_db =
+ let left_ancestors =
+ StringSet.of_list (left_db.Database.hash
+ :: left_db.Database.history)
+ in
+ let right_chain =
+ right_db.Database.hash
+ :: right_db.Database.history
+ in
+ List.find_opt (fun h -> StringSet.mem h left_ancestors) right_chain
+
+(** Apply a single relation diff to a database, using strategy on conflicts. *)
+let apply_diff db ~strategy ~left_db ~right_db ~(left_diff : Diff.relation_diff)
+ ~(right_diff : Diff.relation_diff option) : Database.t * conflict list =
+ match left_diff with
+ | Diff.RelationAdded rel ->
+ (* Only left added it; right_diff must be None or same *)
+ (Database.add_relation db ~relation:rel, [])
+
+ | Diff.RelationRemoved name ->
+ (Database.remove_relation db ~name, [])
+
+ | Diff.RelationModified { name; added_tuples; removed_tuples; schema_changed } ->
+ let conflicts = ref [] in
+ (* Determine the merged relation's Merkle tree *)
+ let base_rel_opt = Database.get_relation db name in
+ (match base_rel_opt with
+ | None -> (db, [])
+ | Some base_rel ->
+ let base_tree = Option.value base_rel.Relation.tree ~default:Merkle.empty in
+ (* Handle schema conflict *)
+ let (resolved_rel, schema_conflict) =
+ if schema_changed then
+ match right_diff with
+ | Some (Diff.RelationModified { schema_changed = true; _ }) ->
+ (* Both changed schema — apply strategy *)
+ let winner = match strategy with
+ | PreferLeft -> Database.get_relation left_db name
+ | PreferRight -> Database.get_relation right_db name
+ | RevertToAncestor -> Some base_rel
+ in
+ (Option.value winner ~default:base_rel, [SchemaConflict name])
+ | _ ->
+ (* Only left changed schema — take left's relation *)
+ let left_rel = Option.value
+ (Database.get_relation left_db name) ~default:base_rel in
+ (left_rel, [])
+ else (base_rel, [])
+ in
+ conflicts := schema_conflict @ !conflicts;
+ (* Apply tuple adds/removes from left *)
+ let merged_tree =
+ List.fold_left (fun t h -> Merkle.insert h t) base_tree added_tuples
+ in
+ let merged_tree =
+ List.fold_left (fun t h -> Merkle.delete h t) merged_tree removed_tuples
+ in
+ (* Apply tuple adds/removes from right if disjoint *)
+ let merged_tree = match right_diff with
+ | Some (Diff.RelationModified
+ { added_tuples = r_add; removed_tuples = r_rem; _ }) ->
+ (* Detect tuple conflicts: same hash both added and removed *)
+ let left_add = StringSet.of_list added_tuples in
+ let left_rem = StringSet.of_list removed_tuples in
+ let right_add = StringSet.of_list r_add in
+ let right_rem = StringSet.of_list r_rem in
+ let conflict_hashes =
+ StringSet.inter left_add right_rem
+ |> StringSet.union (StringSet.inter left_rem right_add)
+ in
+ if not (StringSet.is_empty conflict_hashes) then begin
+ StringSet.iter (fun h ->
+ conflicts := TupleConflict { relation = name; hash = h } :: !conflicts
+ ) conflict_hashes;
+ (* Resolve conflicting tuples per strategy *)
+ match strategy with
+ | PreferLeft ->
+ (* keep left's merged_tree as-is, ignore conflicting right ops *)
+ let safe_add = StringSet.diff right_add conflict_hashes in
+ let safe_rem = StringSet.diff right_rem conflict_hashes in
+ let t = StringSet.fold (fun h acc -> Merkle.insert h acc) safe_add merged_tree in
+ StringSet.fold (fun h acc -> Merkle.delete h acc) safe_rem t
+ | PreferRight ->
+ (* revert left's conflicting ops, apply right's *)
+ let t = StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree in
+ let t = StringSet.fold (fun h acc -> Merkle.insert h acc) right_add t in
+ StringSet.fold (fun h acc -> Merkle.delete h acc) right_rem t
+ | RevertToAncestor ->
+ (* drop conflicting hashes from merged tree *)
+ StringSet.fold (fun h acc -> Merkle.delete h acc) conflict_hashes merged_tree
+ end else begin
+ (* Disjoint — union both sides *)
+ let t = List.fold_left (fun acc h -> Merkle.insert h acc) merged_tree r_add in
+ List.fold_left (fun acc h -> Merkle.delete h acc) t r_rem
+ end
+ | _ -> merged_tree
+ in
+ let new_hash = Hashing.hash_relation
+ ~name:resolved_rel.Relation.name
+ ~schema:resolved_rel.Relation.schema
+ ~tree:merged_tree
+ in
+ let updated_rel = { resolved_rel with
+ Relation.tree = Some merged_tree;
+ hash = Some new_hash;
+ } in
+ let new_db = Database.update_relation db ~relation:updated_rel in
+ (new_db, !conflicts))
+
+module Make
+ (Storage : Physical.S)
+ (Manip : MANIPULATION with type storage = Storage.t) =
+struct
+
+ let err s = Error (Manip.of_string_error s)
+
+ (* Load both tips, find the lowest common ancestor, compute the diffs,
+ lookup for right diffs by relation name, start from ancestor and
+ apply all the diffs, apply first the left diffs, then right-only diffs
+ (relations only right touched). If there are no conflicts, persist the
+ merged database, otherwise return Failed, unless a strategy resolved them. *)
+ let merge ~storage ~strategy ~left_tip ~right_tip =
+ match Manip.load_database storage left_tip with
+ | Error e -> Error e
+ | Ok None -> err ("Left tip not found: " ^ left_tip)
+ | Ok (Some left_db) ->
+ match Manip.load_database storage right_tip with
+ | Error e -> Error e
+ | Ok None -> err ("Right tip not found: " ^ right_tip)
+ | Ok (Some right_db) ->
+ match find_lca left_db right_db with
+ | None -> err "No common ancestor found between branches"
+ | Some ancestor_hash ->
+ match Manip.load_database storage ancestor_hash with
+ | Error e -> Error e
+ | Ok None -> err ("Ancestor not found: " ^ ancestor_hash)
+ | Ok (Some ancestor_db) ->
+ let left_diffs = Diff.diff ~ancestor:ancestor_db ~target:left_db in
+ let right_diffs = Diff.diff ~ancestor:ancestor_db ~target:right_db in
+ let right_diff_map =
+ List.fold_left (fun m d ->
+ let key = match d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ Database.RelationMap.add key d m
+ ) Database.RelationMap.empty right_diffs
+ in
+ let (merged_db, all_conflicts) =
+ let (db_after_left, left_conflicts) =
+ List.fold_left (fun (db, conflicts) left_d ->
+ let rel_name = match left_d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ let right_d = Database.RelationMap.find_opt rel_name right_diff_map in
+ let (new_db, cs) =
+ apply_diff db ~strategy ~left_db ~right_db
+ ~left_diff:left_d ~right_diff:right_d
+ in
+ (new_db, cs @ conflicts)
+ ) (ancestor_db, []) left_diffs
+ in
+ let left_names =
+ List.fold_left (fun s d ->
+ let n = match d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ StringSet.add n s
+ ) StringSet.empty left_diffs
+ in
+ let right_only = List.filter (fun d ->
+ let n = match d with
+ | Diff.RelationAdded r -> r.Relation.name
+ | Diff.RelationRemoved n -> n
+ | Diff.RelationModified { name; _ } -> name
+ in
+ not (StringSet.mem n left_names)
+ ) right_diffs in
+ let (db_final, right_conflicts) =
+ List.fold_left (fun (db, conflicts) right_d ->
+ let (new_db, cs) =
+ apply_diff db ~strategy ~left_db ~right_db
+ ~left_diff:right_d ~right_diff:None
+ in
+ (new_db, cs @ conflicts)
+ ) (db_after_left, left_conflicts) right_only
+ in
+ (db_final, right_conflicts)
+ in
+ let unresolvable = List.filter (function
+ | ConstraintConflict _ -> true
+ | _ -> false
+ ) all_conflicts in
+ if unresolvable <> [] then
+ Ok (Failed unresolvable)
+ else begin
+ match Manip.store_database storage merged_db with
+ | Error e -> Error e
+ | Ok () -> Ok (Clean merged_db)
+ end
+
+end
diff --git a/lib/manipulation.ml b/lib/manipulation.ml
index 2a43b6c..73607fa 100644
--- a/lib/manipulation.ml
+++ b/lib/manipulation.ml
@@ -44,6 +44,8 @@ let build_membership_criteria _schema : (Tuple.t -> bool) =
(** Functor to create manipulation operations with a storage backend *)
module Make (Storage : Management.Physical.S) = struct
type storage = Storage.t
+ type nonrec error = error
+ let of_string_error s = StorageError s
(* Constraint evaluation context *)
diff --git a/lib/prelude/catalog.ml b/lib/prelude/catalog.ml
index a277066..4a7241a 100644
--- a/lib/prelude/catalog.ml
+++ b/lib/prelude/catalog.ml
@@ -15,6 +15,8 @@ let attribute_rel_name = catalog_prefix ^ "attribute"
let constraint_rel_name = catalog_prefix ^ "constraint"
let on_rel_name = catalog_prefix ^ "on"
let timing_rel_name = catalog_prefix ^ "timing"
+let branch_rel_name = catalog_prefix ^ "branch"
+let head_rel_name = catalog_prefix ^ "head"
let catalog_relation_names =
[ relation_rel_name
@@ -111,3 +113,4 @@ let build_timing_tuple timing : Tuple.materialized =
Tuple.AttributeMap.singleton "timing"
{ Attribute.value = Obj.magic timing }
}
+
diff --git a/test/test_relational_engine.ml b/test/test_relational_engine.ml
index 6bb1eed..2b902e1 100644
--- a/test/test_relational_engine.ml
+++ b/test/test_relational_engine.ml
@@ -1630,7 +1630,7 @@ let%test_unit "constraint: evaluate Exists over finite relation" =
let b =
Constraint.BindingMap.empty
|> Constraint.BindingMap.add "left" (Constraint.Var "x")
- |> Constraint.BindingMap.add "right" (Constraint.Var "value")
+ |> Constraint.BindingMap.add "right" (Constraint.Var "value.value")
in
let c =
Constraint.Exists
@@ -1674,7 +1674,7 @@ let%test_unit "constraint: evaluate Forall fails when not all match" =
let b =
Constraint.BindingMap.empty
|> Constraint.BindingMap.add "left" (Constraint.Var "x")
- |> Constraint.BindingMap.add "right" (Constraint.Var "value")
+ |> Constraint.BindingMap.add "right" (Constraint.Var "value.value")
in
let c =
Constraint.Forall
@@ -2583,41 +2583,41 @@ let%test_unit "dml: insert into nonexistent relation returns error" =
============================================================================ *)
let%test_unit "dcl: round-trip RegisterConstraint MemberOf" =
- let src = Dcl.Ast.RegisterConstraint {
+ let src = Icl.Ast.RegisterConstraint {
constraint_name = "fk_order";
relation_name = "order_items";
- body = Dcl.Ast.MemberOf { target = "orders"; binding = [("order_id", Dcl.Ast.Var "order_id")] }
+ body = Icl.Ast.MemberOf { target = "orders"; binding = [("order_id", Icl.Ast.Var "order_id")] }
} in
- match Dcl.Parser.of_string (Dcl.Parser.to_string src) with
+ match Icl.Parser.of_string (Icl.Parser.to_string src) with
| Error _ -> assert false
| Ok parsed -> assert (parsed = src)
let%test_unit "dcl: round-trip And constraint" =
- let src = Dcl.Ast.RegisterConstraint {
+ let src = Icl.Ast.RegisterConstraint {
constraint_name = "valid_range";
relation_name = "scores";
- body = Dcl.Ast.And [
- Dcl.Ast.MemberOf { target = "ge_zero";
- binding = [("left", Dcl.Ast.Var "score"); ("right", Dcl.Ast.Const (Drl.Ast.Int 0))] };
- Dcl.Ast.MemberOf { target = "le_hundred";
- binding = [("left", Dcl.Ast.Var "score"); ("right", Dcl.Ast.Const (Drl.Ast.Int 100))] };
+ body = Icl.Ast.And [
+ Icl.Ast.MemberOf { target = "ge_zero";
+ binding = [("left", Icl.Ast.Var "score"); ("right", Icl.Ast.Const (Drl.Ast.Int 0))] };
+ Icl.Ast.MemberOf { target = "le_hundred";
+ binding = [("left", Icl.Ast.Var "score"); ("right", Icl.Ast.Const (Drl.Ast.Int 100))] };
]
} in
- match Dcl.Parser.of_string (Dcl.Parser.to_string src) with
+ match Icl.Parser.of_string (Icl.Parser.to_string src) with
| Error _ -> assert false
| Ok parsed -> assert (parsed = src)
let%test_unit "dcl: round-trip Not constraint" =
- let src = Dcl.Ast.RegisterConstraint {
+ let src = Icl.Ast.RegisterConstraint {
constraint_name = "not_closed";
relation_name = "open_ticket";
- body = Dcl.Ast.Not {
- body = Dcl.Ast.MemberOf { target = "closed_ticket";
- binding = [("ticket_id", Dcl.Ast.Var "ticket_id")] };
+ body = Icl.Ast.Not {
+ body = Icl.Ast.MemberOf { target = "closed_ticket";
+ binding = [("ticket_id", Icl.Ast.Var "ticket_id")] };
universe = "open_ticket"
}
} in
- match Dcl.Parser.of_string (Dcl.Parser.to_string src) with
+ match Icl.Parser.of_string (Icl.Parser.to_string src) with
| Error _ -> assert false
| Ok parsed -> assert (parsed = src)
@@ -2630,14 +2630,14 @@ let%test_unit "dcl: execute RegisterConstraint attaches constraint" =
let db = match Manipulation.Memory.create_relation storage db ~name:"order_items" ~schema with
| Error _ -> assert false | Ok (db, _) -> db
in
- let stmt = Dcl.Ast.RegisterConstraint {
+ let stmt = Icl.Ast.RegisterConstraint {
constraint_name = "fk_order";
relation_name = "order_items";
- body = Dcl.Ast.MemberOf { target = "orders"; binding = [("order_id", Dcl.Ast.Var "order_id")] }
+ body = Icl.Ast.MemberOf { target = "orders"; binding = [("order_id", Icl.Ast.Var "order_id")] }
} in
- match Dcl.Executor.Memory.execute storage db stmt with
+ match Icl.Executor.Memory.execute storage db stmt with
| Error _ -> assert false
- | Ok db ->
+ | Ok (db, _) ->
let rel = match Management.Database.get_relation db "order_items" with
| None -> assert false | Some r -> r
in
@@ -2662,13 +2662,13 @@ let%test_unit "dcl: FK constraint enforced on insert" =
| Error _ -> assert false | Ok (db, _) -> db
in
(* Register FK: order_id in order_items must match id in orders *)
- let db = match Dcl.Executor.Memory.execute storage db
- (Dcl.Ast.RegisterConstraint {
+ let db = match Icl.Executor.Memory.execute storage db
+ (Icl.Ast.RegisterConstraint {
constraint_name = "fk_order";
relation_name = "order_items";
- body = Dcl.Ast.MemberOf { target = "orders"; binding = [("id", Dcl.Ast.Var "order_id")] }
+ body = Icl.Ast.MemberOf { target = "orders"; binding = [("id", Icl.Ast.Var "order_id")] }
}) with
- | Error _ -> assert false | Ok db -> db
+ | Error _ -> assert false | Ok (db, _) -> db
in
(* Valid insert: order_id=1 exists in orders *)
let db = match Dml.Executor.Memory.execute storage db
@@ -2684,3 +2684,249 @@ let%test_unit "dcl: FK constraint enforced on insert" =
(Dml.Ast.InsertTuple { relation = "order_items"; attributes = [("order_id", Drl.Ast.Int 99)] }) with
| Error (Dml.Executor.Memory.ManipulationError (Manipulation.ConstraintViolation _)) -> ()
| _ -> assert false)
+
+(* ============================================================================
+ Branch Tests
+ ============================================================================ *)
+
+module BranchMemory = Management.Branch.Make(Management.Physical.Memory)
+
+let%test_unit "branch: create and get_tip" =
+ with_storage (fun storage ->
+ let tip = "deadbeef" in
+ (match BranchMemory.create storage ~name:"main" ~tip with
+ | Error _ -> assert false
+ | Ok () -> ());
+ match BranchMemory.get_tip storage "main" with
+ | Error _ -> assert false
+ | Ok None -> assert false
+ | Ok (Some t) -> assert (t = tip))
+
+let%test_unit "branch: get_tip returns None for unknown branch" =
+ with_storage (fun storage ->
+ match BranchMemory.get_tip storage "nonexistent" with
+ | Error _ -> assert false
+ | Ok None -> ()
+ | Ok (Some _) -> assert false)
+
+let%test_unit "branch: checkout and get_head" =
+ with_storage (fun storage ->
+ (match BranchMemory.create storage ~name:"main" ~tip:"abc" with
+ | Error _ -> assert false | Ok () -> ());
+ (match BranchMemory.checkout storage "main" with
+ | Error _ -> assert false | Ok () -> ());
+ match BranchMemory.get_head storage with
+ | Error _ -> assert false
+ | Ok None -> assert false
+ | Ok (Some h) -> assert (h = "main"))
+
+let%test_unit "branch: get_head returns None when not set" =
+ with_storage (fun storage ->
+ match BranchMemory.get_head storage with
+ | Error _ -> assert false
+ | Ok None -> ()
+ | Ok (Some _) -> assert false)
+
+let%test_unit "branch: update_tip advances the branch" =
+ with_storage (fun storage ->
+ (match BranchMemory.create storage ~name:"main" ~tip:"v1" with
+ | Error _ -> assert false | Ok () -> ());
+ (match BranchMemory.update_tip storage ~name:"main" ~tip:"v2" with
+ | Error _ -> assert false | Ok () -> ());
+ match BranchMemory.get_tip storage "main" with
+ | Error _ -> assert false
+ | Ok None -> assert false
+ | Ok (Some t) -> assert (t = "v2"))
+
+let%test_unit "branch: update_tip fails on unknown branch" =
+ with_storage (fun storage ->
+ match BranchMemory.update_tip storage ~name:"ghost" ~tip:"v1" with
+ | Error _ -> ()
+ | Ok () -> assert false)
+
+let%test_unit "branch: multiple branches are independent" =
+ with_storage (fun storage ->
+ (match BranchMemory.create storage ~name:"main" ~tip:"hash-main" with
+ | Error _ -> assert false | Ok () -> ());
+ (match BranchMemory.create storage ~name:"feature" ~tip:"hash-feature" with
+ | Error _ -> assert false | Ok () -> ());
+ let main_tip = match BranchMemory.get_tip storage "main" with
+ | Ok (Some t) -> t | _ -> assert false
+ in
+ let feat_tip = match BranchMemory.get_tip storage "feature" with
+ | Ok (Some t) -> t | _ -> assert false
+ in
+ assert (main_tip = "hash-main");
+ assert (feat_tip = "hash-feature");
+ assert (main_tip <> feat_tip))
+
+(* ============================================================================
+ Diff Tests
+ ============================================================================ *)
+
+let%test_unit "diff: identical databases produce empty diff" =
+ with_storage (fun storage ->
+ let db = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let diffs = Management.Diff.diff ~ancestor:db ~target:db in
+ assert (diffs = []))
+
+let%test_unit "diff: added relation detected" =
+ with_storage (fun storage ->
+ let ancestor = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let schema = Schema.empty |> Schema.add "x" "natural" in
+ let target, _ = match Manipulation.Memory.create_relation storage ancestor
+ ~name:"new_rel" ~schema with
+ | Error _ -> assert false | Ok p -> p
+ in
+ let diffs = Management.Diff.diff ~ancestor ~target in
+ let added = List.filter_map (function
+ | Management.Diff.RelationAdded r -> Some r
+ | _ -> None) diffs
+ in
+ assert (List.exists (fun r -> r.Relation.name = "new_rel") added))
+
+let%test_unit "diff: removed relation detected" =
+ with_storage (fun storage ->
+ let schema = Schema.empty |> Schema.add "x" "natural" in
+ let ancestor = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let ancestor, _ = match Manipulation.Memory.create_relation storage ancestor
+ ~name:"gone" ~schema with
+ | Error _ -> assert false | Ok p -> p
+ in
+ let target = match Manipulation.Memory.retract_relation storage ancestor ~name:"gone" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let diffs = Management.Diff.diff ~ancestor ~target in
+ let removed = List.filter_map (function
+ | Management.Diff.RelationRemoved n -> Some n
+ | _ -> None) diffs
+ in
+ assert (List.mem "gone" removed))
+
+let%test_unit "diff: modified relation detected with added tuple" =
+ with_storage (fun storage ->
+ let schema = Schema.empty |> Schema.add "val" "natural" in
+ let ancestor = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let ancestor, _ = match Manipulation.Memory.create_relation storage ancestor
+ ~name:"r" ~schema with
+ | Error _ -> assert false | Ok p -> p
+ in
+ let rel = Option.get (Management.Database.get_relation ancestor "r") in
+ let t : Tuple.materialized = {
+ Tuple.relation = "r";
+ attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 42 };
+ } in
+ let (target, _, _) = match Manipulation.Memory.create_tuple storage ancestor rel t with
+ | Error _ -> assert false | Ok p -> p
+ in
+ let diffs = Management.Diff.diff ~ancestor ~target in
+ assert (List.length diffs = 1);
+ match diffs with
+ | [ Management.Diff.RelationModified { name; added_tuples; removed_tuples; _ } ] ->
+ assert (name = "r");
+ assert (List.length added_tuples = 1);
+ assert (removed_tuples = [])
+ | _ -> assert false)
+
+(* ============================================================================
+ Merge Tests
+ ============================================================================ *)
+
+module MergeMemory = Management.Merge.Make
+ (Management.Physical.Memory)
+ (Manipulation.Memory)
+
+let%test_unit "merge: fast-forward when only one side changed" =
+ with_storage (fun storage ->
+ let schema = Schema.empty |> Schema.add "val" "natural" in
+ let base_db = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let base_db, _ = match Manipulation.Memory.create_relation storage base_db
+ ~name:"r" ~schema with
+ | Error _ -> assert false | Ok p -> p
+ in
+ (match Manipulation.Memory.store_database storage base_db with
+ | Error _ -> assert false | Ok () -> ());
+ let rel = Option.get (Management.Database.get_relation base_db "r") in
+ let t1 : Tuple.materialized = {
+ Tuple.relation = "r";
+ attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 1 };
+ } in
+ let (left_db, _, _) = match Manipulation.Memory.create_tuple storage base_db rel t1 with
+ | Error _ -> assert false | Ok p -> p
+ in
+ (match Manipulation.Memory.store_database storage left_db with
+ | Error _ -> assert false | Ok () -> ());
+ match MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft
+ ~left_tip:left_db.Management.Database.hash
+ ~right_tip:base_db.Management.Database.hash with
+ | Error _ -> assert false
+ | Ok (Management.Merge.Failed _) -> assert false
+ | Ok (Management.Merge.Clean merged) ->
+ let merged_rel = Option.get (Management.Database.get_relation merged "r") in
+ assert (Manipulation.Memory.tuple_count merged_rel = 1))
+
+let%test_unit "merge: independent tuple additions produce union" =
+ with_storage (fun storage ->
+ let schema = Schema.empty |> Schema.add "val" "natural" in
+ let base_db = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ let base_db, _ = match Manipulation.Memory.create_relation storage base_db
+ ~name:"r" ~schema with
+ | Error _ -> assert false | Ok p -> p
+ in
+ (match Manipulation.Memory.store_database storage base_db with
+ | Error _ -> assert false | Ok () -> ());
+ let rel = Option.get (Management.Database.get_relation base_db "r") in
+ let t_left : Tuple.materialized = {
+ Tuple.relation = "r";
+ attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 10 };
+ } in
+ let (left_db, _, _) = match Manipulation.Memory.create_tuple storage base_db rel t_left with
+ | Error _ -> assert false | Ok p -> p
+ in
+ (match Manipulation.Memory.store_database storage left_db with
+ | Error _ -> assert false | Ok () -> ());
+ let t_right : Tuple.materialized = {
+ Tuple.relation = "r";
+ attributes = Tuple.AttributeMap.singleton "val" { Attribute.value = Obj.repr 20 };
+ } in
+ let (right_db, _, _) = match Manipulation.Memory.create_tuple storage base_db rel t_right with
+ | Error _ -> assert false | Ok p -> p
+ in
+ (match Manipulation.Memory.store_database storage right_db with
+ | Error _ -> assert false | Ok () -> ());
+ match MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft
+ ~left_tip:left_db.Management.Database.hash
+ ~right_tip:right_db.Management.Database.hash with
+ | Error _ -> assert false
+ | Ok (Management.Merge.Failed _) -> assert false
+ | Ok (Management.Merge.Clean merged) ->
+ let merged_rel = Option.get (Management.Database.get_relation merged "r") in
+ assert (Manipulation.Memory.tuple_count merged_rel = 2))
+
+let%test_unit "merge: no-op when both sides are identical" =
+ with_storage (fun storage ->
+ let base_db = match Manipulation.Memory.create_database storage ~name:"db" with
+ | Error _ -> assert false | Ok db -> db
+ in
+ (match Manipulation.Memory.store_database storage base_db with
+ | Error _ -> assert false | Ok () -> ());
+ match MergeMemory.merge ~storage ~strategy:Management.Merge.PreferLeft
+ ~left_tip:base_db.Management.Database.hash
+ ~right_tip:base_db.Management.Database.hash with
+ | Error _ -> assert false
+ | Ok (Management.Merge.Failed _) -> assert false
+ | Ok (Management.Merge.Clean merged) ->
+ assert (Management.Database.get_relation_names merged =
+ Management.Database.get_relation_names base_db))
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 07:30:05 +0000