Monorepo management for opam overlays
1type error =
2 | Git_error of Git_cli.error
3 | Feature_exists of string
4 | Feature_not_found of string
5 | Config_error of string
6
7let pp_error ppf = function
8 | Git_error e -> Fmt.pf ppf "Git error: %a" Git_cli.pp_error e
9 | Feature_exists name -> Fmt.pf ppf "Feature '%s' already exists" name
10 | Feature_not_found name -> Fmt.pf ppf "Feature '%s' not found" name
11 | Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
12
13let error_hint = function
14 | Git_error _ -> Some "Check that the monorepo is properly initialized"
15 | Feature_exists name ->
16 Some
17 (Fmt.str
18 "Run 'monopam feature remove %s' first if you want to recreate it"
19 name)
20 | Feature_not_found name ->
21 Some
22 (Fmt.str
23 "Run 'monopam feature list' to see available features, or 'monopam \
24 feature add %s' to create it"
25 name)
26 | Config_error _ ->
27 Some "Run 'monopam init' to create a workspace configuration"
28
29let pp_error_with_hint ppf e =
30 pp_error ppf e;
31 match error_hint e with
32 | Some hint -> Fmt.pf ppf "@.Hint: %s" hint
33 | None -> ()
34
35type entry = { name : string; path : Fpath.t; branch : string }
36
37let pp_entry ppf e =
38 Fmt.pf ppf "%s -> %a (branch: %s)" e.name Fpath.pp e.path e.branch
39
40(* Get the work directory path: root/work *)
41let work_path config = Fpath.(Verse_config.root config / "work")
42
43(* Get the feature worktree path: root/work/<name> *)
44let path config name = Fpath.(work_path config / name)
45
46let add ~sw ~fs ~config ~name () =
47 let mono = Verse_config.mono_path config in
48 let work_dir = work_path config in
49 let wt_path = path config name in
50 let repo = Git.Repository.open_repo ~sw ~fs mono in
51 let wt = Git.Repository.worktree repo in
52 (* Check if feature already exists *)
53 if Git.Worktree.exists wt ~path:wt_path then Error (Feature_exists name)
54 else begin
55 (* Ensure work directory exists *)
56 let work_eio = Eio.Path.(fs / Fpath.to_string work_dir) in
57 (try Eio.Path.mkdirs ~perm:0o755 work_eio with Eio.Io _ -> ());
58 (* Create the worktree with a new branch *)
59 match Git.Repository.head repo with
60 | None -> Error (Config_error "no HEAD commit in monorepo")
61 | Some head -> (
62 match Git.Worktree.add wt ~head ~path:wt_path ~branch:name with
63 | Error (`Msg msg) -> Error (Config_error msg)
64 | Ok () -> Ok { name; path = wt_path; branch = name })
65 end
66
67let remove ~sw ~fs ~config ~name ~force () =
68 let mono = Verse_config.mono_path config in
69 let wt_path = path config name in
70 let repo = Git.Repository.open_repo ~sw ~fs mono in
71 let wt = Git.Repository.worktree repo in
72 (* Check if feature exists *)
73 if not (Git.Worktree.exists wt ~path:wt_path) then
74 Error (Feature_not_found name)
75 else
76 match Git.Worktree.remove wt ~path:wt_path ~force with
77 | Error (`Msg msg) -> Error (Config_error msg)
78 | Ok () -> Ok ()
79
80let list ~sw ~fs ~config () =
81 let mono = Verse_config.mono_path config in
82 let work_dir = work_path config in
83 let repo = Git.Repository.open_repo ~sw ~fs mono in
84 let wt = Git.Repository.worktree repo in
85 let all_worktrees =
86 Git.Worktree.list wt ~head:(Git.Repository.head repo)
87 ~current_branch:(Git.Repository.current_branch repo)
88 in
89 (* Filter to only worktrees under work/ directory *)
90 List.filter_map
91 (fun (e : Git.Worktree.entry) ->
92 (* Check if this worktree is under the work directory *)
93 let wt_str = Fpath.to_string e.path in
94 let work_str = Fpath.to_string work_dir in
95 if String.starts_with ~prefix:work_str wt_str then
96 let name = Fpath.basename e.path in
97 let branch = Option.value ~default:name e.branch in
98 Some { name; path = e.path; branch }
99 else None)
100 all_worktrees