1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
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
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 (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)
|
