diff options
Diffstat (limited to 'lib/dcl/executor.ml')
| -rw-r--r-- | lib/dcl/executor.ml | 126 |
1 files changed, 83 insertions, 43 deletions
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) |