Branching and naïve merge strategies

* AGPL license

* branching and merging

* Delete LICENSE in favor of separate PR

Signed-off-by: Marcos Magueta <maguetamarcos@gmail.com>

* add unmonitored tests and docs

---------

Signed-off-by: Marcos Magueta <maguetamarcos@gmail.com>

3 files changed, 97 insertions, 61 deletions

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))