aboutsummaryrefslogtreecommitdiffstats
path: root/lib/dcl
diff options
context:
space:
mode:
Diffstat (limited to 'lib/dcl')
-rw-r--r--lib/dcl/executor.ml147
1 files changed, 76 insertions, 71 deletions
diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml
index 8c2fbdc..a651067 100644
--- a/lib/dcl/executor.ml
+++ b/lib/dcl/executor.ml
@@ -4,16 +4,24 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
module MergeOps = Management.Merge.Make (Storage) (Ops)
type error =
- | ParseError of string
- | BranchError of string
- | MergeError of string
+ | ParseError of string
+ | BranchError of Error.t
+ | BranchNotFound of string
+ | NoDatabaseAtHash of Conventions.Hash.t
+ | StorageError of string
+ | MergeError of Error.t
+ | Conflict of string
let sexp_of_error e =
let open Sexplib.Sexp in
match e with
- | ParseError s -> List [ Atom "parse-error"; Atom s ]
- | BranchError s -> List [ Atom "branch-error"; Atom s ]
- | MergeError s -> List [ Atom "merge-error"; Atom s ]
+ | ParseError s -> List [Atom "parse-error"; Atom s]
+ | BranchError s -> List [Atom "branch-error"; Error.sexp_of_error s]
+ | BranchNotFound s -> List [Atom "branch-not-found"; Atom s]
+ | NoDatabaseAtHash s -> List [Atom "no-database-at-hash"; Atom s]
+ | StorageError s -> List [Atom "storage-error"; Atom s]
+ | MergeError s -> List [Atom "merge-error"; Error.sexp_of_error s]
+ | Conflict s -> List [Atom "conflict"; Atom s]
let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy =
function
@@ -24,71 +32,68 @@ module Make (Storage : Management.Physical.S with type error = string) = struct
let execute (storage : Storage.t) (db : Management.Database.t)
(stmt : Ast.statement) : (Management.Database.t * string, error) result =
match stmt with
- | Ast.CreateBranch { name; hash } -> (
- let tip =
- match hash with Some h -> h | None -> db.Management.Database.hash
- in
- match Branch.create storage ~name ~tip with
- | Error e -> Error (BranchError e)
- | Ok () -> Ok (db, "Branch " ^ name ^ " created"))
- | Ast.Checkout branch_name -> (
- match Branch.get_tip storage branch_name with
- | Error e -> Error (BranchError e)
- | Ok None -> Error (BranchError ("Branch not found: " ^ branch_name))
- | Ok (Some tip) -> (
- match Branch.checkout storage branch_name with
- | Error e -> Error (BranchError e)
- | Ok () -> (
- match Ops.load_database storage tip with
- | Error e ->
- Error (BranchError (Manipulation.string_of_error e))
- | Ok None -> Error (BranchError ("No database at hash: " ^ tip))
- | Ok (Some loaded_db) -> Ok (loaded_db, "HEAD:" ^ branch_name)))
- )
- | Ast.GetHead -> (
- match Branch.get_head storage with
- | Error e -> Error (BranchError e)
- | Ok None -> Ok (db, "HEAD is unset")
- | Ok (Some name) -> Ok (db, "HEAD:" ^ name))
- | Ast.GetBranchTip name -> (
- match Branch.get_tip storage name with
- | Error e -> Error (BranchError e)
- | Ok None -> Error (BranchError ("Branch not found: " ^ name))
- | Ok (Some hash) -> Ok (db, "branch:" ^ name ^ "=" ^ hash))
- | Ast.UpdateBranchTip { name; hash } -> (
- match Branch.update_tip storage ~name ~tip:hash with
- | Error e -> Error (BranchError e)
- | Ok () -> Ok (db, "Branch " ^ name ^ " updated"))
- | Ast.Merge { left; right; strategy } -> (
- match (Branch.get_tip storage left, Branch.get_tip storage right) with
- | Error e, _ | _, Error e -> Error (BranchError e)
- | Ok None, _ -> Error (BranchError ("Branch not found: " ^ left))
- | _, Ok None -> Error (BranchError ("Branch not found: " ^ right))
- | Ok (Some left_tip), Ok (Some right_tip) -> (
- let strat = convert_strategy strategy in
- match
- MergeOps.merge ~storage ~strategy:strat ~left_tip ~right_tip
- with
- | Error e -> Error (MergeError (Manipulation.string_of_error e))
- | Ok (Management.Merge.Failed conflicts) ->
- let msgs =
- List.map
- (function
- | Management.Merge.TupleConflict { relation; hash } ->
- "tuple conflict in " ^ relation ^ " (" ^ hash ^ ")"
- | Management.Merge.SchemaConflict r ->
- "schema conflict in " ^ r
- | Management.Merge.ConstraintConflict r ->
- "constraint conflict in " ^ r)
- conflicts
- in
- Error (MergeError ("Merge failed: " ^ String.concat "; " msgs))
- | Ok (Management.Merge.Clean merged_db) ->
- let _ =
- Branch.update_tip storage ~name:left
- ~tip:merged_db.Management.Database.hash
- in
- Ok (merged_db, "Merged:" ^ right ^ "→" ^ left)))
+ | Ast.CreateBranch { name; hash } ->
+ let tip = match hash with
+ | Some h -> h
+ | None -> db.Management.Database.hash
+ in
+ (match Branch.create storage ~name ~tip with
+ | Error e -> Error (StorageError e)
+ | Ok () -> Ok (db, "Branch " ^ name ^ " created"))
+
+ | Ast.Checkout branch_name ->
+ (match Branch.get_tip storage branch_name with
+ | Error e -> Error (StorageError e)
+ | Ok None -> Error (BranchNotFound branch_name)
+ | Ok (Some tip) ->
+ (match Branch.checkout storage branch_name with
+ | Error e -> Error (StorageError e)
+ | Ok () ->
+ (match Ops.load_database storage tip with
+ | Error e -> Error (BranchError e)
+ | Ok None -> Error (NoDatabaseAtHash tip)
+ | Ok (Some loaded_db) ->
+ Ok (loaded_db, "HEAD:" ^ branch_name))))
+
+ | Ast.GetHead ->
+ (match Branch.get_head storage with
+ | Error e -> Error (StorageError 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 (StorageError e)
+ | Ok None -> Error (BranchNotFound 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 (StorageError 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 (StorageError e)
+ | Ok None, _ -> Error (BranchNotFound left)
+ | _, Ok None -> Error (BranchNotFound 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 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 (Conflict ("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)
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 06:50:53 +0000