diff options
| author | Marcos Magueta <maguetamarcos@gmail.com> | 2026-04-03 16:17:38 -0300 |
|---|---|---|
| committer | Marcos Magueta <maguetamarcos@gmail.com> | 2026-04-03 16:17:38 -0300 |
| commit | 63ae3c930de89af6f85229a467caa3f53cb844a2 (patch) | |
| tree | cda4d513672f9fefa09c3a1dff69d8443890e224 /lib/dcl | |
| parent | c5bc3a4992b4968780c286a084ad7c02b2b58f1e (diff) | |
| download | Sakura-63ae3c930de89af6f85229a467caa3f53cb844a2.tar.gz Sakura-63ae3c930de89af6f85229a467caa3f53cb844a2.zip | |
format
Diffstat (limited to 'lib/dcl')
| -rw-r--r-- | lib/dcl/ast.ml | 6 | ||||
| -rw-r--r-- | lib/dcl/executor.ml | 160 | ||||
| -rw-r--r-- | lib/dcl/parser.ml | 14 | ||||
| -rw-r--r-- | lib/dcl/sublanguage.ml | 8 |
4 files changed, 92 insertions, 96 deletions
diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml index e1dae13..0b6107f 100644 --- a/lib/dcl/ast.ml +++ b/lib/dcl/ast.ml @@ -4,10 +4,10 @@ type merge_strategy = PreferLeft | PreferRight | RevertToAncestor [@@deriving sexp] type statement = - | CreateBranch of { name: string; hash: string option [@sexp.option] } + | 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 } + | 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 cf2cfed..8c2fbdc 100644 --- a/lib/dcl/executor.ml +++ b/lib/dcl/executor.ml @@ -1,94 +1,94 @@ 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) + module Ops = Manipulation.Make (Storage) + module Branch = Management.Branch.Make (Storage) + module MergeOps = Management.Merge.Make (Storage) (Ops) type error = - | ParseError of string + | ParseError of string | BranchError of string - | MergeError of string + | MergeError 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"; Atom s ] + | MergeError s -> List [ Atom "merge-error"; Atom s ] - let convert_strategy : Ast.merge_strategy -> Management.Merge.strategy = function - | Ast.PreferLeft -> Management.Merge.PreferLeft - | Ast.PreferRight -> Management.Merge.PreferRight + 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 = + 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 (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))) end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml index ef64924..79d8fc7 100644 --- a/lib/dcl/parser.ml +++ b/lib/dcl/parser.ml @@ -3,16 +3,12 @@ type error = ParseError of string let of_sexp sexp = (* ppx_sexp_conv encodes no-argument variants as bare atoms, so unwrap a single-element list (e.g. (GetHead)) → atom (GetHead). *) - let sexp = match sexp with - | Sexplib.Sexp.List [atom] -> atom - | other -> other + let sexp = + match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other in match Ast.statement_of_sexp sexp with - | stmt -> Ok stmt + | stmt -> Ok stmt | exception exn -> Error (ParseError (Printexc.to_string exn)) -let of_string s = - of_sexp (Sexplib.Sexp.of_string s) - -let to_string stmt = - Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum +let of_string s = of_sexp (Sexplib.Sexp.of_string s) +let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml index 112b6ed..c36e2a4 100644 --- a/lib/dcl/sublanguage.ml +++ b/lib/dcl/sublanguage.ml @@ -1,9 +1,9 @@ module Make (Storage : Management.Physical.S with type error = string) = struct - module Exec = Executor.Make(Storage) + module Exec = Executor.Make (Storage) type storage = Storage.t - type ast = Ast.statement - type error = Exec.error + type ast = Ast.statement + type error = Exec.error let name = "dcl" @@ -20,4 +20,4 @@ module Make (Storage : Management.Physical.S with type error = string) = struct let sexp_of_error = Exec.sexp_of_error end -module Memory = Make(Management.Physical.Memory) +module Memory = Make (Management.Physical.Memory) |
