Multigroup unified reference for hierarchical access

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)