diff options
Diffstat (limited to 'lib/dcl/executor.ml')
| -rw-r--r-- | lib/dcl/executor.ml | 108 |
1 files changed, 0 insertions, 108 deletions
diff --git a/lib/dcl/executor.ml b/lib/dcl/executor.ml deleted file mode 100644 index b83f629..0000000 --- a/lib/dcl/executor.ml +++ /dev/null @@ -1,108 +0,0 @@ -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 = - | 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"; 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 - | Ast.PreferLeft -> Management.Merge.PreferLeft - | Ast.PreferRight -> Management.Merge.PreferRight - | Ast.RevertToAncestor -> Management.Merge.RevertToAncestor - - type exec_result = - | DbResult of Management.Database.t * string - | Switch of string - | NewMultigroup of string - - let execute (storage : Storage.t) (db : Management.Database.t) - (stmt : Ast.statement) : (exec_result, 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 (StorageError e) - | Ok () -> Ok (DbResult (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 (DbResult (loaded_db, "HEAD:" ^ branch_name))))) - | Ast.GetHead -> ( - match Branch.get_head storage with - | Error e -> Error (StorageError e) - | Ok None -> Ok (DbResult (db, "HEAD is unset")) - | Ok (Some name) -> Ok (DbResult (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 (DbResult (db, "branch:" ^ name ^ "=" ^ hash))) - | Ast.UpdateBranchTip { name; hash } -> ( - match Branch.update_tip storage ~name ~tip:hash with - | Error e -> Error (StorageError e) - | Ok () -> Ok (DbResult (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 (DbResult (merged_db, "Merged:" ^ right ^ "→" ^ left)))) - | Ast.Use multigroup -> Ok (Switch multigroup) - | Ast.CreateMultigroup name -> Ok (NewMultigroup name) -end - -module Memory = Make (Management.Physical.Memory) |