diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/dcl/ast.ml | 15 | ||||
| -rw-r--r-- | lib/dcl/executor.ml | 108 | ||||
| -rw-r--r-- | lib/dcl/parser.ml | 14 | ||||
| -rw-r--r-- | lib/dcl/sublanguage.ml | 29 |
4 files changed, 0 insertions, 166 deletions
diff --git a/lib/dcl/ast.ml b/lib/dcl/ast.ml deleted file mode 100644 index a55ec19..0000000 --- a/lib/dcl/ast.ml +++ /dev/null @@ -1,15 +0,0 @@ -open Sexplib.Std - -type merge_strategy = PreferLeft | PreferRight | RevertToAncestor -[@@deriving sexp] - -type statement = - | 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 } - | Use of string - | CreateMultigroup of string -[@@deriving sexp] 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) diff --git a/lib/dcl/parser.ml b/lib/dcl/parser.ml deleted file mode 100644 index 79d8fc7..0000000 --- a/lib/dcl/parser.ml +++ /dev/null @@ -1,14 +0,0 @@ -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 - in - match Ast.statement_of_sexp sexp with - | 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 diff --git a/lib/dcl/sublanguage.ml b/lib/dcl/sublanguage.ml deleted file mode 100644 index 34d4c62..0000000 --- a/lib/dcl/sublanguage.ml +++ /dev/null @@ -1,29 +0,0 @@ -module Make (Storage : Management.Physical.S with type error = string) = struct - module Exec = Executor.Make (Storage) - - type configuration = unit - type storage = Storage.t - type ast = Ast.statement - type error = Exec.error - - let name = "dcl" - let parse _ = Ok () - - let parse_sexp sexp = - match Parser.of_sexp sexp with - | Ok r -> Ok r - | Error (Parser.ParseError s) -> Error (Exec.ParseError s) - - let execute storage db ast = - match Exec.execute storage db ast with - | Ok (Exec.DbResult (db, _)) -> Ok (Sublanguage_types.Transition db) - | Ok (Exec.Switch multigroup) -> - Ok (Sublanguage_types.SessionSwitch multigroup) - | Ok (Exec.NewMultigroup name) -> - Ok (Sublanguage_types.CreateMultigroup name) - | Error e -> Error e - - let sexp_of_error = Exec.sexp_of_error -end - -module Memory = Make (Management.Physical.Memory) |