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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
open B0_std
open Result.Syntax
let pp_cli_arg fmt = Fmt.tty [`Underline] fmt
let fpath_pp_high_suffix pre ppf p = match Fpath.strip_prefix pre p with
| None -> (Fmt.code Fpath.pp) ppf p
| Some p ->
Fpath.pp ppf pre;
(if not (Fpath.is_dir_path pre) then Fmt.char ppf Fpath.dir_sep_char);
(Fmt.code Fpath.pp) ppf p
type t =
{ base : Fpath.t;
prefix : Fpath.t;
time : Os.Mtime.counter;
vcs : B00_vcs.t }
let make ?vcs ?prefix env ~base =
let scope_dir = B0_cmdlet.Env.scope_dir env in
let prefix = Option.value ~default:scope_dir prefix in
let* vcs = match vcs with
| None -> B00_vcs.get ~dir:scope_dir () | Some vcs -> Ok vcs
in
let time = Os.Mtime.counter () in
let base = Fpath.(prefix // base) in
Ok { base; prefix; time; vcs }
let prefix exp = exp.prefix
let base exp = exp.base
let base_files exp ~recurse =
Os.Dir.fold_files ~recurse Os.Dir.path_list exp.base []
let dur exp = Os.Mtime.count exp.time
module Outcome = struct
type status = [ `Corrected | `Expected | `New | `Unexpected | `Unknown ]
let merge_statuses sts =
let merge acc st = match acc, st with
| `Unknown, _ | _, `Unknown -> `Unknown
| `Unexpected, _ | _, `Unexpected -> `Unexpected
| `New, _ | _, `New -> `New
| `Corrected, _ | _, `Corrected -> `Corrected
| `Expected, `Expected -> `Expected
in
List.fold_left merge `Expected sts
type t = status
let status = Fun.id
let merge = merge_statuses
end
let file_outcome r file = match B00_vcs.kind r.vcs with
| B00_vcs.Git ->
let git = B00_vcs.repo_cmd r.vcs in
let cmd = Cmd.(git % "status" % "--porcelain" %% path file) in
let* st = Os.Cmd.run_out ~trim:false cmd in
begin match String.take_left 2 st with
| "" -> Ok `Expected
| "M " | "A " -> Ok `Corrected
| "??" -> Ok `New
| s when s.[1] = 'M' -> Ok `Unexpected
| _ -> Ok `Unknown
end
| B00_vcs.Hg ->
failwith "TODO"
let pp_label ppf o =
let label ppf st l = Fmt.tty_string st ppf (String.concat " " [""; l; ""]) in
match o with
| `Unexpected -> label ppf [`Bg `Red; `Fg `White] "M"
| `New -> label ppf [`Bg `Yellow; `Fg `Black] "?"
let log_outcome r file = function
| `Unexpected | `New as o ->
Log.app (fun m -> m "%a %a" pp_label o (fpath_pp_high_suffix r.prefix) file)
| _ -> ()
let pp_vcs_cmd vcs ?(file = false) ppf cmd =
let pp_file_arg ppf () = Fmt.(pp_cli_arg string) ppf "file" in
let file = if file then pp_file_arg else Fmt.nop in
Fmt.pf ppf "%a %a" Fmt.(code string) (String.concat " " [vcs; cmd]) file ()
let pp_git = pp_vcs_cmd "git"
let pp_hg = pp_vcs_cmd "hg"
let pp_new_cmd ppf vcs = match B00_vcs.kind vcs with
| B00_vcs.Git -> pp_git ~file:true ppf "add"
| B00_vcs.Hg -> pp_hg ppf ~file:true "TODO"
let pp_correct_cmd ppf vcs = match B00_vcs.kind vcs with
| B00_vcs.Git -> pp_git ~file:true ppf "add -p"
| B00_vcs.Hg -> pp_hg ~file:true ppf "TODO"
let pp_unexpected_cmd ppf vcs = match B00_vcs.kind vcs with
| B00_vcs.Git -> pp_git ~file:true ppf "diff"
| B00_vcs.Hg -> pp_hg ppf ~file:true "TODO"
let pp_status_cmd ppf (vcs, dir) = match B00_vcs.kind vcs with
| B00_vcs.Git -> pp_git ppf ("status -s " ^ Fpath.to_string dir)
| B00_vcs.Hg -> pp_hg ppf "TODO"
let pp_diff_cmd ppf (vcs, dir) = match B00_vcs.kind vcs with
| B00_vcs.Git -> pp_git ppf ("diff " ^ Fpath.to_string dir)
| B00_vcs.Hg -> pp_hg ppf "TODO"
let pp_status st status =
Fmt.tty st (fun ppf c -> Fmt.pf ppf "%d %s" c status)
let pp_corrected ppf n = if n = 0 then () else Fmt.pf ppf " (%d corrected)" n
let pp_expected = pp_status [`Fg `Green] "expected"
let pp_unexpected = pp_status [`Fg `Red] "unexpected"
let pp_new = pp_status [`Fg `Yellow] "new"
let pp_unknown = pp_status [`Fg `Red] "unknown"
let pp_expected ppf = function
| (0, _) -> () | (n, c) -> Fmt.pf ppf "@,%a%a" pp_expected n pp_corrected c
let pp_unexpected ppf = function
| (0, _) -> () | (n, vcs) ->
Fmt.pf ppf "@,%a (check with %a, correct with %a)"
pp_unexpected n pp_unexpected_cmd vcs pp_correct_cmd vcs
let pp_new ppf = function
| (0, _) -> () | (n, vcs) ->
Fmt.pf ppf "@,%a (integrate with %a)" pp_new n pp_new_cmd vcs
let pp_unknown ppf = function 0 -> () | n -> Fmt.pf ppf "@,%a" pp_unknown n
let pp_all_pass ppf (count, corr, dur) =
let test = if count > 1 then "tests expected" else "test expected" in
let green = [`Fg `Green] in
Fmt.pf ppf "%a %a%a in %a"
(Fmt.tty_string green) "All" (pp_status green test) count
pp_corrected corr Mtime.Span.pp dur
let pp_total ppf (count, dur) =
let test = if count > 1 then "tests" else "test" in
Fmt.pf ppf "@,%a in %a" (pp_status [`Bold] test) count Mtime.Span.pp dur
let log_results exp os =
let expected = ref 0 and unexpected = ref 0 and new' = ref 0
and corrected = ref 0 and unknown = ref 0 in
let incr o = match Outcome.status o with
| `Expected -> incr expected | `Unexpected -> incr unexpected
| `New -> incr new' | `Corrected -> incr expected; incr corrected
| `Unknown -> incr unknown
in
let count = List.length os in
let () = List.iter incr os in
match !expected = count with
| true ->
Log.app (fun m -> m "%a" pp_all_pass (count, !corrected, dur exp));
B00_cli.Exit.ok
| false ->
Log.app (fun m ->
m "@[<v> @[<v>%a%a%a%a%a@]@,@,\
Summary with %a@,Details with %a@]"
pp_expected (!expected, !corrected) pp_new (!new', exp.vcs)
pp_unknown !unknown pp_unexpected (!unexpected, exp.vcs)
pp_total (count, dur exp)
pp_status_cmd (exp.vcs, exp.base)
pp_diff_cmd (exp.vcs, exp.base));
Os.Exit.code 1
let stdout exp ?env ?cwd ~stdout:out cmd =
let stdout = Os.Cmd.out_file ~force:true ~make_path:true out in
let* () = Os.Cmd.run ?env ?cwd ~stdout cmd in
let* o = file_outcome exp out in
log_outcome exp out o;
Ok o