[OCaml] High Intensity Training Online
fix Reconcile downstream core interfaces
Adapt persistence, application, presenter, and web layers to the HD1 core update. Preserve quantified beyond-failure extensions on the wire and collect their rep or hold count in workout forms. Reduce subjective feedback to Motivation and Difficulty with relative ternary values. Legacy numeric feedback values map to the equivalent ternary level. Rename downstream Progression references to Progress. Extend tests for decompensation, the per-muscle set ceiling, quantified extensions, and relative feedback. The full check, all 327 tests, and formatting pass.
Changed files
- lib/app/service.ml
- lib/app/service.mli
- lib/persistence/codec.ml
- lib/presenter/pages_logbook.ml
- lib/presenter/pages_workout.ml
- lib/presenter/view_model.ml
- lib/web/decode.ml
- lib/web/handlers_kit.ml
- lib/web/handlers_logbook.ml
- test/test_codec.ml
- test/test_evidence.ml
- test/test_import_service.ml
- test/test_prescription.ml
- test/test_progression.ml
- test/test_service.ml
- test/test_sqlite_repo.ml
- test/test_web.ml
lib/app/service.ml
@@ -299,10 +299,10 @@
299
299
300
300
(* --- what the record means --- *)
301
301
module Assessment = struct
302
Removed:
(* Progression judges one exercise across all evidence, native and
302
Added:
(* Progress judges one exercise across all evidence, native and
303
303
imported alike. Provenance never changes the verdict: an observation is
304
304
an observation. Merge the two sources, keep only the requested exercise,
305
Removed:
and order oldest-first by [performed_at] so {!Progression.assess} sees a
305
Added:
and order oldest-first by [performed_at] so {!Progress.assess} sees a
306
306
chronological series. Ties order native before imported — an arbitrary
307
307
but fixed rule that keeps the merge deterministic. *)
308
308
let merged_observations ~log ~records exercise =
@@ -327,9 +327,9 @@
327
327
let progress t trainee exercise =
328
328
R.log t.repo trainee >>= fun log ->
329
329
R.imported_records t.repo trainee >|= fun records ->
330
Removed:
match Progression.assess (merged_observations ~log ~records exercise) with
330
Added:
match Progress.assess (merged_observations ~log ~records exercise) with
331
331
| assessment -> Ok assessment
332
Removed:
| exception Progression.Invalid error -> Error error
332
Added:
| exception Progress.Invalid error -> Error error
333
333
334
334
(* Diagnostics stay native-only. They name overtraining habits from a
335
335
workout's prescription, its volume, its clearance, and its extensions.
@@ -338,7 +338,7 @@
338
338
to measure against. Folding imports in would fabricate habits the record
339
339
cannot support. *)
340
340
let diagnostics t trainee =
341
Removed:
R.log t.repo trainee >|= fun log -> Progression.diagnose log
341
Added:
R.log t.repo trainee >|= fun log -> Progress.diagnose log
342
342
end
343
343
344
344
(* --- subjective feedback --- *)
lib/app/service.mli
@@ -172,16 +172,16 @@
172
172
173
173
val workout_log : t -> Trainee.id -> Evidence.Log.t Lwt.t
174
174
(** The trainee's native workout log, for judging progress across history.
175
Removed:
Distinct from imported records, which {!Progression} merges only per
175
Added:
Distinct from imported records, which {!Progress} merges only per
176
176
exercise. *)
177
177
178
178
val progress :
179
179
t ->
180
180
Trainee.id ->
181
181
Exercise.t ->
182
Removed:
(Progression.assessment, Progression.error) result Lwt.t
182
Added:
(Progress.assessment, Progress.error) result Lwt.t
183
183
184
Removed:
val diagnostics : t -> Trainee.id -> Progression.diagnostic list Lwt.t
184
Added:
val diagnostics : t -> Trainee.id -> Progress.diagnostic list Lwt.t
185
185
(** Habits the record shows that HD1 names as causes of overtraining. *)
186
186
187
187
(** {2 Subjective feedback} *)
lib/persistence/codec.ml
@@ -17,17 +17,25 @@
17
17
(* --- extension and outcome codes --- *)
18
18
19
19
let extension_code : Evidence.Stimulus.extension -> string = function
20
Removed:
| Forced_reps -> "forced"
21
Removed:
| Negatives -> "negatives"
22
Removed:
| Rest_pause -> "rest-pause"
23
Removed:
| Static_hold -> "static"
20
Added:
| Forced_reps reps -> Printf.sprintf "forced=%d" reps
21
Added:
| Negatives reps -> Printf.sprintf "negatives=%d" reps
22
Added:
| Static_hold seconds -> Printf.sprintf "static=%d" seconds
24
23
25
Removed:
let extension_of_code = function
26
Removed:
| "forced" -> Ok Evidence.Stimulus.Forced_reps
27
Removed:
| "negatives" -> Ok Evidence.Stimulus.Negatives
28
Removed:
| "rest-pause" -> Ok Evidence.Stimulus.Rest_pause
29
Removed:
| "static" -> Ok Evidence.Stimulus.Static_hold
30
Removed:
| other -> Error (Malformed (Printf.sprintf "extension %S" other))
24
Added:
let extension_of_code code =
25
Added:
match String.split_on_char '=' code with
26
Added:
| [ "forced"; reps ] -> (
27
Added:
match int_of_string_opt reps with
28
Added:
| Some reps -> Ok (Evidence.Stimulus.Forced_reps reps)
29
Added:
| None -> Error (Malformed (Printf.sprintf "extension %S" code)))
30
Added:
| [ "negatives"; reps ] -> (
31
Added:
match int_of_string_opt reps with
32
Added:
| Some reps -> Ok (Evidence.Stimulus.Negatives reps)
33
Added:
| None -> Error (Malformed (Printf.sprintf "extension %S" code)))
34
Added:
| [ "static"; seconds ] -> (
35
Added:
match int_of_string_opt seconds with
36
Added:
| Some seconds -> Ok (Evidence.Stimulus.Static_hold seconds)
37
Added:
| None -> Error (Malformed (Printf.sprintf "extension %S" code)))
38
Added:
| _ -> Error (Malformed (Printf.sprintf "extension %S" code))
31
39
32
40
let encode_outcome (outcome : Evidence.Stimulus.outcome) =
33
41
match outcome with
@@ -315,26 +323,20 @@
315
323
316
324
(* --- subjective feedback --- *)
317
325
318
Removed:
let level_code (l : Evidence.Feedback.level) =
319
Removed:
string_of_int (Evidence.Feedback.level_to_score l)
326
Added:
let level_code : Evidence.Feedback.level -> string = function
327
Added:
| Worse_than_usual -> "worse"
328
Added:
| As_usual -> "usual"
329
Added:
| Better_than_usual -> "better"
320
330
321
Removed:
let level_of_code code =
322
Removed:
match int_of_string_opt code with
323
Removed:
| Some n -> (
324
Removed:
match Evidence.Feedback.level_of_score n with
325
Removed:
| Some l -> Ok l
326
Removed:
| None -> Error (Malformed (Printf.sprintf "level %S" code)))
327
Removed:
| None -> Error (Malformed (Printf.sprintf "level %S" code))
331
Added:
let level_of_code = function
332
Added:
| "worse" | "1" | "2" -> Ok Evidence.Feedback.Worse_than_usual
333
Added:
| "usual" | "3" -> Ok Evidence.Feedback.As_usual
334
Added:
| "better" | "4" | "5" -> Ok Evidence.Feedback.Better_than_usual
335
Added:
| code -> Error (Malformed (Printf.sprintf "level %S" code))
328
336
329
337
let signal_code : Evidence.Feedback.signal -> string = function
330
Removed:
| Sleep l -> "sleep:" ^ level_code l
331
Removed:
| Appetite l -> "appetite:" ^ level_code l
332
Removed:
| Readiness l -> "readiness:" ^ level_code l
333
338
| Motivation l -> "motivation:" ^ level_code l
334
339
| Difficulty l -> "difficulty:" ^ level_code l
335
Removed:
| Pain -> "pain"
336
Removed:
| Injury -> "injury"
337
Removed:
| Preparation_insufficient -> "preparation-insufficient"
338
340
339
341
let signal_of_code code =
340
342
let leveled make rest =
@@ -342,15 +344,8 @@
342
344
Ok (make l)
343
345
in
344
346
match String.split_on_char ':' code with
345
Removed:
| [ "sleep"; l ] -> leveled (fun l -> Evidence.Feedback.Sleep l) l
346
Removed:
| [ "appetite"; l ] -> leveled (fun l -> Evidence.Feedback.Appetite l) l
347
Removed:
| [ "readiness"; l ] -> leveled (fun l -> Evidence.Feedback.Readiness l) l
348
347
| [ "motivation"; l ] -> leveled (fun l -> Evidence.Feedback.Motivation l) l
349
348
| [ "difficulty"; l ] -> leveled (fun l -> Evidence.Feedback.Difficulty l) l
350
Removed:
| [ "pain" ] -> Ok Evidence.Feedback.Pain
351
Removed:
| [ "injury" ] -> Ok Evidence.Feedback.Injury
352
Removed:
| [ "preparation-insufficient" ] ->
353
Removed:
Ok Evidence.Feedback.Preparation_insufficient
354
349
| _ -> Error (Malformed (Printf.sprintf "signal %S" code))
355
350
356
351
let encode_feedback report =
lib/presenter/pages_logbook.ml
@@ -2,21 +2,11 @@
2
2
open Page_kit
3
3
open Page_shell
4
4
5
Removed:
(* The subjective feedback form. Radio groups report sleep, appetite,
6
Removed:
readiness, motivation, and difficulty against a personal baseline. Flags
7
Removed:
report pain, injury, and insufficient preparation. A field left blank reports
8
Removed:
nothing, so the trainee submits only what they mean to. Feedback is
9
Removed:
standalone — recorded from the Logbook at any time. *)
5
Added:
(* HD1-grounded self-reports, each relative to the trainee's usual baseline. *)
10
6
type feedback_flow = { step : int; answers : (string * string) list }
11
7
12
8
let feedback_factors =
13
Removed:
[
14
Removed:
("sleep", "Sleep");
15
Removed:
("appetite", "Appetite");
16
Removed:
("readiness", "Readiness");
17
Removed:
("motivation", "Motivation");
18
Removed:
("difficulty", "Perceived difficulty");
19
Removed:
]
9
Added:
[ ("motivation", "Motivation"); ("difficulty", "Perceived difficulty") ]
20
10
21
11
(* Each subjective metric uses five unselected radio buttons styled as inline
22
12
buttons. The server shows one metric at a time. *)
@@ -49,40 +39,28 @@
49
39
Dream_html.string_attr "aria-label" "%s" label;
50
40
]
51
41
[
52
Removed:
choice "1" "1 — very poor";
53
Removed:
choice "2" "2";
54
Removed:
choice "3" "3";
55
Removed:
choice "4" "4";
56
Removed:
choice "5" "5 — very good";
42
Added:
choice "worse" "Worse than usual";
43
Added:
choice "usual" "As usual";
44
Added:
choice "better" "Better than usual";
57
45
];
58
46
]
59
47
60
Removed:
let feedback_flag field label =
61
Removed:
tag "label"
62
Removed:
[ class_ "feedback-flag" ]
63
Removed:
[
64
Removed:
void "input"
65
Removed:
[
66
Removed:
type_ "checkbox";
67
Removed:
Dream_html.string_attr "name" "%s" field;
68
Removed:
value "true";
69
Removed:
];
70
Removed:
txt " %s" label;
71
Removed:
]
72
Removed:
73
48
let feedback_progress step =
74
Removed:
let completed = min 5 (max 0 step) in
49
Added:
let total = List.length feedback_factors in
50
Added:
let completed = min total (max 0 step) in
75
51
tag "div"
76
52
[ class_ "feedback-progress" ]
77
53
[
78
54
tag "progress"
79
55
[
80
56
Dream_html.string_attr "value" "%s" (string_of_int completed);
81
Removed:
Dream_html.string_attr "max" "5";
57
Added:
Dream_html.string_attr "max" "%d" total;
82
58
Dream_html.string_attr "aria-label" "Feedback progress";
83
59
]
84
Removed:
[ txt "%d of 5 factors" completed ];
85
Removed:
tag "p" [ class_ "ledger-meta" ] [ txt "%d of 5 factors" completed ];
60
Added:
[ txt "%d of %d factors" completed total ];
61
Added:
tag "p"
62
Added:
[ class_ "ledger-meta" ]
63
Added:
[ txt "%d of %d factors" completed total ];
86
64
]
87
65
88
66
let feedback_action_button ~action ~label ?(secondary = false) () =
@@ -97,7 +75,8 @@
97
75
[ txt "%s" label ]
98
76
99
77
let feedback_flow_form request flow =
100
Removed:
let step = min 5 (max 0 flow.step) in
78
Added:
let total = List.length feedback_factors in
79
Added:
let step = min total (max 0 flow.step) in
101
80
let fields =
102
81
[
103
82
void "input"
@@ -117,7 +96,7 @@
117
96
]
118
97
in
119
98
let body =
120
Removed:
if step < 5 then
99
Added:
if step < total then
121
100
let field, label = List.nth feedback_factors step in
122
101
fields
123
102
@ [
@@ -144,17 +123,9 @@
144
123
else
145
124
fields
146
125
@ [
147
Removed:
tag "h3" [] [ txt "Anything else?" ];
148
Removed:
tag "p" []
149
Removed:
[ txt "Add an optional note about pain, injury, or preparation." ];
150
Removed:
tag "div"
151
Removed:
[ class_ "field" ]
152
Removed:
[
153
Removed:
feedback_flag "pain" "Pain";
154
Removed:
feedback_flag "injury" "Injury";
155
Removed:
feedback_flag "preparation" "Preparation was insufficient";
156
Removed:
];
157
Removed:
feedback_progress 5;
126
Added:
tag "h3" [] [ txt "Ready to save" ];
127
Added:
tag "p" [] [ txt "Submit the feedback you chose to report." ];
128
Added:
feedback_progress total;
158
129
tag "div"
159
130
[ class_ "feedback-actions" ]
160
131
[
lib/presenter/pages_workout.ml
@@ -28,7 +28,6 @@
28
28
option "" "to positive failure";
29
29
option "forced" "then forced reps";
30
30
option "negatives" "then negatives";
31
Removed:
option "rest-pause" "then rest-pause";
32
31
option "static" "then a static hold";
33
32
]
34
33
@@ -124,8 +123,8 @@
124
123
action. Load and reps of each movement are laid out side by side. *)
125
124
let form_for_stimulus request ~action_path ~slot
126
125
~(movements : View_model.Workout.movement list) ~selected_extension
127
Removed:
?(enhanced = false) ?(submit = "Record") ~(errors : (string * string) list)
128
Removed:
() =
126
Added:
~selected_extension_amount ?(enhanced = false) ?(submit = "Record")
127
Added:
~(errors : (string * string) list) () =
129
128
let field_id field = Printf.sprintf "slot-%d-%s" slot field in
130
129
let selected = selected_extension in
131
130
(* A single-exercise slot shows one row with a visible "Reps to failure"
@@ -154,7 +153,7 @@
154
153
List.concat_map
155
154
(fun (m : View_model.Workout.movement) -> [ m.load_field; m.reps_field ])
156
155
movements
157
Removed:
@ [ "extension" ]
156
Added:
@ [ "extension"; "extension_amount" ]
158
157
in
159
158
tag "form"
160
159
([ action_path; post_form ]
@@ -181,6 +180,26 @@
181
180
~invalid:(List.mem_assoc "extension" errors)
182
181
~input_id:(field_id "extension") ();
183
182
];
183
Added:
tag "div"
184
Added:
[ class_ "field field-extension-amount" ]
185
Added:
[
186
Added:
tag "label"
187
Added:
[
188
Added:
Dream_html.string_attr "for" "%s"
189
Added:
(field_id "extension_amount");
190
Added:
]
191
Added:
[ txt "Extension reps / hold seconds" ];
192
Added:
void "input"
193
Added:
[
194
Added:
type_ "number";
195
Added:
name "extension_amount";
196
Added:
Dream_html.string_attr "id" "%s"
197
Added:
(field_id "extension_amount");
198
Added:
Dream_html.string_attr "min" "1";
199
Added:
Dream_html.string_attr "value" "%s"
200
Added:
selected_extension_amount;
201
Added:
];
202
Added:
];
184
203
])
185
204
:: List.concat_map
186
205
(fun field -> error_for ~input_id:(field_id field) field errors)
@@ -310,16 +329,18 @@
310
329
tag "p" [ class_ "done" ] [ txt "%s" summary ];
311
330
form_for_stimulus request ~action_path:(edit_action active_slot)
312
331
~slot:active_slot ~movements:slot.movements
313
Removed:
~selected_extension:slot.selected_extension ~enhanced
314
Removed:
~submit:"Save correction" ~errors ();
332
Added:
~selected_extension:slot.selected_extension
333
Added:
~selected_extension_amount:slot.selected_extension_amount
334
Added:
~enhanced ~submit:"Save correction" ~errors ();
315
335
]
316
336
| None ->
317
337
[
318
338
form_for_stimulus request
319
339
~action_path:(record_action active_slot)
320
340
~slot:active_slot ~movements:slot.movements
321
Removed:
~selected_extension:slot.selected_extension ~enhanced ~errors
322
Removed:
();
341
Added:
~selected_extension:slot.selected_extension
342
Added:
~selected_extension_amount:slot.selected_extension_amount
343
Added:
~enhanced ~errors ();
323
344
]
324
345
in
325
346
[ tag "section" [ class_ "slot-panel" ] (heading :: body) ]
lib/presenter/view_model.ml
@@ -102,8 +102,10 @@
102
102
entity. *)
103
103
selected_extension : string;
104
104
(** The ending code to pre-select when correcting a recorded slot ("",
105
Removed:
"forced", "negatives", "rest-pause", "static"). "" for an
106
Removed:
outstanding slot. *)
105
Added:
"forced", "negatives", "static"). *)
106
Added:
selected_extension_amount : string;
107
Added:
(** Reps for forced reps/negatives or seconds for a static hold.
108
Added:
Defaults to one for an outstanding slot. *)
107
109
}
108
110
109
111
type t = {
@@ -127,7 +129,7 @@
127
129
date : string; (** Workout date, pre-formatted "YYYY-MM-DD" in UTC. *)
128
130
progressed_exercises : int;
129
131
(** How many exercises beat their previous record, judged by
130
Removed:
{!Progression}. *)
132
Added:
{!Progress}. *)
131
133
}
132
134
(** One saved workout as the logbook table shows it: a link, a name, the date,
133
135
and how many exercises progressed. No Repository record and no
lib/web/decode.ml
@@ -14,12 +14,11 @@
14
14
extension : Evidence.Stimulus.extension option;
15
15
}
16
16
17
Removed:
let extension = function
17
Added:
let extension_kind = function
18
18
| "" -> Ok None
19
Removed:
| "forced" -> Ok (Some Evidence.Stimulus.Forced_reps)
20
Removed:
| "negatives" -> Ok (Some Evidence.Stimulus.Negatives)
21
Removed:
| "rest-pause" -> Ok (Some Evidence.Stimulus.Rest_pause)
22
Removed:
| "static" -> Ok (Some Evidence.Stimulus.Static_hold)
19
Added:
| "forced" -> Ok (Some (fun n -> Evidence.Stimulus.Forced_reps n))
20
Added:
| "negatives" -> Ok (Some (fun n -> Evidence.Stimulus.Negatives n))
21
Added:
| "static" -> Ok (Some (fun n -> Evidence.Stimulus.Static_hold n))
23
22
| _ -> Error "error.extension"
24
23
25
24
let load value =
@@ -36,18 +35,26 @@
36
35
37
36
let fields prescription =
38
37
let open Form in
38
Added:
let ending =
39
Added:
let* make = required extension_kind "extension" in
40
Added:
let* amount = optional reps "extension_amount" in
41
Added:
match (make, amount) with
42
Added:
| None, _ -> ok None
43
Added:
| Some make, Some amount -> ok (Some (make amount))
44
Added:
| Some _, None -> error "extension_amount" "error.required"
45
Added:
in
39
46
match Prescription.Stimulus.delivery prescription with
40
47
| Prescription.Stimulus.Single _ ->
41
48
let+ load = required load "load"
42
49
and+ reps = required reps "reps"
43
Removed:
and+ extension = required extension "extension" in
50
Added:
and+ extension = ending in
44
51
Single { load; reps; extension }
45
52
| Prescription.Stimulus.Pre_exhaust _ ->
46
53
let+ iso_load = required load "iso_load"
47
54
and+ iso_reps = required reps "iso_reps"
48
55
and+ comp_load = required load "comp_load"
49
56
and+ comp_reps = required reps "comp_reps"
50
Removed:
and+ extension = required extension "extension" in
57
Added:
and+ extension = ending in
51
58
Pair { iso_load; iso_reps; comp_load; comp_reps; extension }
52
59
53
60
let stimulus prescription =
lib/web/handlers_kit.ml
@@ -182,15 +182,15 @@
182
182
183
183
(* The ending code a single-choice form uses, taken from an effort's outcome.
184
184
The form offers one ending, so the first extension stands for it. *)
185
Removed:
let extension_code_of_effort effort =
185
Added:
let extension_of_effort effort =
186
186
match Evidence.Stimulus.Effort.outcome effort with
187
Removed:
| Evidence.Stimulus.Positive_failure -> ""
187
Added:
| Evidence.Stimulus.Positive_failure -> ("", "1")
188
188
| Evidence.Stimulus.Beyond_failure (first, _) -> (
189
189
match first with
190
Removed:
| Evidence.Stimulus.Forced_reps -> "forced"
191
Removed:
| Evidence.Stimulus.Negatives -> "negatives"
192
Removed:
| Evidence.Stimulus.Rest_pause -> "rest-pause"
193
Removed:
| Evidence.Stimulus.Static_hold -> "static")
190
Added:
| Evidence.Stimulus.Forced_reps reps -> ("forced", string_of_int reps)
191
Added:
| Evidence.Stimulus.Negatives reps -> ("negatives", string_of_int reps)
192
Added:
| Evidence.Stimulus.Static_hold seconds ->
193
Added:
("static", string_of_int seconds))
194
194
195
195
(* One line describing a recorded stimulus: the efforts joined by "into", then
196
196
any extensions appended. *)
@@ -282,14 +282,14 @@
282
282
};
283
283
]
284
284
in
285
Removed:
let selected_extension =
285
Added:
let selected_extension, selected_extension_amount =
286
286
match recorded with
287
Removed:
| None -> ""
287
Added:
| None -> ("", "1")
288
288
| Some s -> (
289
289
(* The ending lives on the last effort (the compound of a pair). *)
290
290
match List.rev (Evidence.Stimulus.efforts s) with
291
Removed:
| last :: _ -> extension_code_of_effort last
292
Removed:
| [] -> "")
291
Added:
| last :: _ -> extension_of_effort last
292
Added:
| [] -> ("", "1"))
293
293
in
294
294
{
295
295
index;
@@ -297,6 +297,7 @@
297
297
movements;
298
298
recorded_summary = Option.map describe_stimulus recorded;
299
299
selected_extension;
300
Added:
selected_extension_amount;
300
301
}
301
302
in
302
303
let overridden =
lib/web/handlers_logbook.ml
@@ -13,7 +13,7 @@
13
13
let feedback_factors = List.map fst Pages.feedback_factors
14
14
15
15
let valid_choice = function
16
Removed:
| ("1" | "2" | "3" | "4" | "5") as choice -> Some choice
16
Added:
| ("worse" | "usual" | "better") as choice -> Some choice
17
17
| _ -> None
18
18
19
19
let valid_factor field = List.mem field feedback_factors
@@ -29,7 +29,7 @@
29
29
| [ step; answers ] -> (
30
30
match int_of_string_opt step with
31
31
| None -> None
32
Removed:
| Some step when step < 0 || step > 5 -> None
32
Added:
| Some step when step < 0 || step > List.length feedback_factors -> None
33
33
| Some step ->
34
34
let answers =
35
35
answers |> String.split_on_char ';'
@@ -59,14 +59,11 @@
59
59
60
60
let field name fields = List.assoc_opt name fields
61
61
62
Removed:
let feedback_signals answers flags =
63
Removed:
let level choice =
64
Removed:
match int_of_string_opt choice with
65
Removed:
| Some n -> (
66
Removed:
match Evidence.Feedback.level_of_score n with
67
Removed:
| Some l -> l
68
Removed:
| None -> Evidence.Feedback.Fair)
69
Removed:
| None -> Evidence.Feedback.Fair
62
Added:
let feedback_signals answers _fields =
63
Added:
let level = function
64
Added:
| "worse" -> Evidence.Feedback.Worse_than_usual
65
Added:
| "better" -> Evidence.Feedback.Better_than_usual
66
Added:
| _ -> Evidence.Feedback.As_usual
70
67
in
71
68
let leveled field make =
72
69
List.find_map
@@ -76,54 +73,30 @@
76
73
else None)
77
74
answers
78
75
in
79
Removed:
let optional_flag name signal =
80
Removed:
match field name flags with Some "true" -> Some signal | _ -> None
81
Removed:
in
82
76
List.filter_map Fun.id
83
77
[
84
Removed:
leveled "sleep" (fun l -> Evidence.Feedback.Sleep l);
85
Removed:
leveled "appetite" (fun l -> Evidence.Feedback.Appetite l);
86
Removed:
leveled "readiness" (fun l -> Evidence.Feedback.Readiness l);
87
78
leveled "motivation" (fun l -> Evidence.Feedback.Motivation l);
88
79
leveled "difficulty" (fun l -> Evidence.Feedback.Difficulty l);
89
Removed:
optional_flag "pain" Evidence.Feedback.Pain;
90
Removed:
optional_flag "injury" Evidence.Feedback.Injury;
91
Removed:
optional_flag "preparation" Evidence.Feedback.Preparation_insufficient;
92
80
]
93
81
94
Removed:
(* Describe one signal for the list, and compute a factor's score for the
95
Removed:
graph. These read the Evidence.Feedback entity here in the controller, so
96
Removed:
the presenter receives only strings and scores. *)
97
82
let describe_signal (signal : Evidence.Feedback.signal) =
98
Removed:
let level l =
99
Removed:
let score = Evidence.Feedback.level_to_score l in
100
Removed:
match l with
101
Removed:
| Evidence.Feedback.Very_poor -> Printf.sprintf "%d (very poor)" score
102
Removed:
| Very_good -> Printf.sprintf "%d (very good)" score
103
Removed:
| _ -> string_of_int score
104
Removed:
in
83
Added:
let level l = Format.asprintf "%a" Evidence.Feedback.pp_level l in
105
84
match signal with
106
Removed:
| Sleep l -> Printf.sprintf "Sleep %s" (level l)
107
Removed:
| Appetite l -> Printf.sprintf "Appetite %s" (level l)
108
Removed:
| Readiness l -> Printf.sprintf "Readiness %s" (level l)
109
85
| Motivation l -> Printf.sprintf "Motivation %s" (level l)
110
86
| Difficulty l -> Printf.sprintf "Difficulty %s" (level l)
111
Removed:
| Pain -> "Pain"
112
Removed:
| Injury -> "Injury"
113
Removed:
| Preparation_insufficient -> "Preparation insufficient"
114
87
115
Removed:
let factor_fields =
116
Removed:
[ "sleep"; "appetite"; "readiness"; "motivation"; "difficulty" ]
88
Added:
let factor_fields = [ "motivation"; "difficulty" ]
117
89
118
90
let factor_score field (report : Evidence.Feedback.t) =
91
Added:
let score = function
92
Added:
| Evidence.Feedback.Worse_than_usual -> 1
93
Added:
| As_usual -> 2
94
Added:
| Better_than_usual -> 3
95
Added:
in
119
96
let of_signal (signal : Evidence.Feedback.signal) =
120
97
match (field, signal) with
121
Removed:
| "sleep", Sleep l
122
Removed:
| "appetite", Appetite l
123
Removed:
| "readiness", Readiness l
124
Removed:
| "motivation", Motivation l
125
Removed:
| "difficulty", Difficulty l ->
126
Removed:
Some (Evidence.Feedback.level_to_score l)
98
Added:
| "motivation", Motivation l | "difficulty", Difficulty l ->
99
Added:
Some (score l)
127
100
| _ -> None
128
101
in
129
102
List.find_map of_signal (Evidence.Feedback.signals report)
@@ -143,7 +116,7 @@
143
116
date =
144
117
Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900)
145
118
(tm.Unix.tm_mon + 1) tm.Unix.tm_mday;
146
Removed:
progressed_exercises = Progression.workout_progress log workout;
119
Added:
progressed_exercises = Progress.workout_progress log workout;
147
120
}
148
121
149
122
let feedback_view (report : Evidence.Feedback.t) : View_model.Feedback.report
@@ -233,7 +206,7 @@
233
206
let previous = Pages.{ flow with step = step - 1 } in
234
207
set_feedback_flow request previous >>= fun () ->
235
208
redirect_to request Routes.logbook
236
Removed:
else if step = 5 then
209
Added:
else if step = List.length feedback_factors then
237
210
if action = Some "skip" then
238
211
finish_feedback t trainee request flow []
239
212
else if action = Some "save" then
test/test_codec.ml
@@ -42,7 +42,7 @@
42
42
(move "laterals" 12. 8
43
43
~outcome:
44
44
(Stimulus.Beyond_failure
45
Removed:
(Stimulus.Forced_reps, [ Stimulus.Negatives ])))) )
45
Added:
(Stimulus.Forced_reps 2, [ Stimulus.Negatives 2 ])))) )
46
46
in
47
47
if finished then Workout.finish w ~ended_at:(at 3700) else w
48
48
@@ -187,34 +187,19 @@
187
187
188
188
let feedback_tests =
189
189
[
190
Removed:
( "five-point feedback round-trips every score",
190
Added:
( "relative feedback round-trips every level",
191
191
`Quick,
192
192
fun () ->
193
193
let open Evidence.Feedback in
194
194
let report =
195
195
make ~reported_at:(at 100)
196
Removed:
[
197
Removed:
Sleep Very_poor;
198
Removed:
Appetite Poor;
199
Removed:
Readiness Fair;
200
Removed:
Motivation Good;
201
Removed:
Difficulty Very_good;
202
Removed:
Pain;
203
Removed:
]
196
Added:
[ Motivation Better_than_usual; Difficulty Worse_than_usual ]
204
197
in
205
198
match Codec.decode_feedback (Codec.encode_feedback report) with
206
199
| Ok decoded ->
207
Removed:
let show s =
208
Removed:
let lvl l = string_of_int (level_to_score l) in
209
Removed:
match s with
210
Removed:
| Sleep l -> "sleep:" ^ lvl l
211
Removed:
| Appetite l -> "appetite:" ^ lvl l
212
Removed:
| Readiness l -> "readiness:" ^ lvl l
213
Removed:
| Motivation l -> "motivation:" ^ lvl l
214
Removed:
| Difficulty l -> "difficulty:" ^ lvl l
215
Removed:
| Pain -> "pain"
216
Removed:
| Injury -> "injury"
217
Removed:
| Preparation_insufficient -> "preparation"
200
Added:
let show = function
201
Added:
| Motivation l -> Format.asprintf "motivation:%a" pp_level l
202
Added:
| Difficulty l -> Format.asprintf "difficulty:%a" pp_level l
218
203
in
219
204
Alcotest.(check int)
220
205
"report time" 100
@@ -224,12 +209,24 @@
224
209
(List.map show (signals report))
225
210
(List.map show (signals decoded))
226
211
| Error e -> Alcotest.failf "decode failed: %a" Codec.pp_error e );
227
Removed:
( "an out-of-range score is reported as malformed",
212
Added:
( "legacy numeric levels map to the ternary scale",
228
213
`Quick,
229
214
fun () ->
230
Removed:
match Codec.decode_feedback "1970-01-01T00:00:00Z\tsleep:6" with
231
Removed:
| Error (Codec.Malformed _) -> ()
232
Removed:
| _ -> Alcotest.fail "expected Malformed for score 6" );
215
Added:
match
216
Added:
Codec.decode_feedback
217
Added:
"1970-01-01T00:00:00Z\tmotivation:2,difficulty:5"
218
Added:
with
219
Added:
| Ok report ->
220
Added:
Alcotest.(check bool)
221
Added:
"legacy levels mapped" true
222
Added:
(Evidence.Feedback.signals report
223
Added:
= [
224
Added:
Evidence.Feedback.Motivation
225
Added:
Evidence.Feedback.Worse_than_usual;
226
Added:
Evidence.Feedback.Difficulty
227
Added:
Evidence.Feedback.Better_than_usual;
228
Added:
])
229
Added:
| Error e -> Alcotest.failf "decode failed: %a" Codec.pp_error e );
233
230
]
234
231
235
232
let suite =
test/test_evidence.ml
@@ -47,11 +47,12 @@
47
47
`Quick,
48
48
fun () ->
49
49
let o =
50
Removed:
Stimulus.Beyond_failure (Stimulus.Forced_reps, [ Stimulus.Negatives ])
50
Added:
Stimulus.Beyond_failure
51
Added:
(Stimulus.Forced_reps 2, [ Stimulus.Negatives 2 ])
51
52
in
52
53
Alcotest.(check (list string))
53
54
"forced reps then negatives"
54
Removed:
[ "forced reps"; "negatives" ]
55
Added:
[ "forced reps x 2"; "negatives x 2" ]
55
56
(List.map
56
57
(Format.asprintf "%a" Stimulus.pp_extension)
57
58
(Stimulus.extensions_of_outcome o)) );
@@ -102,7 +103,7 @@
102
103
(move
103
104
~outcome:
104
105
(Stimulus.Beyond_failure
105
Removed:
(Stimulus.Forced_reps, [ Stimulus.Negatives ]))
106
Added:
(Stimulus.Forced_reps 2, [ Stimulus.Negatives 2 ]))
106
107
"dips" 0. 6)
107
108
in
108
109
Alcotest.(check bool) "extended" true (Stimulus.is_extended s);
@@ -251,7 +252,7 @@
251
252
`Quick,
252
253
fun () ->
253
254
(* HD1 forbids extra volume, but the log must still say what happened;
254
Removed:
diagnosing it is Progression's job. *)
255
Added:
diagnosing it is Progress's job. *)
255
256
let w = perform [ single "laterals" 12. 8; single "laterals" 12. 6 ] in
256
257
Alcotest.(check int) "two stimuli" 2 (List.length (Workout.stimuli w));
257
258
Alcotest.(check int)
@@ -562,31 +563,26 @@
562
563
let open Feedback in
563
564
match
564
565
try
565
Removed:
ignore (make ~reported_at:(at 60) [ Sleep Poor; Sleep Good ]);
566
Added:
ignore
567
Added:
(make ~reported_at:(at 60)
568
Added:
[ Motivation Worse_than_usual; Motivation Better_than_usual ]);
566
569
None
567
570
with Invalid error -> Some error
568
571
with
569
Removed:
| Some (Duplicate_signal (Sleep Good)) -> ()
570
Removed:
| _ -> Alcotest.fail "expected duplicate sleep rejection" );
571
Removed:
( "feedback retains its report time and signals",
572
Added:
| Some (Duplicate_signal (Motivation Better_than_usual)) -> ()
573
Added:
| _ -> Alcotest.fail "expected duplicate motivation rejection" );
574
Added:
( "feedback retains its report time and relative signals",
572
575
`Quick,
573
576
fun () ->
574
577
let open Feedback in
575
578
let feedback =
576
579
make ~reported_at:(at 60)
577
Removed:
[
578
Removed:
Sleep Good;
579
Removed:
Appetite Fair;
580
Removed:
Readiness Good;
581
Removed:
Motivation Good;
582
Removed:
Difficulty Fair;
583
Removed:
Preparation_insufficient;
584
Removed:
]
580
Added:
[ Motivation Better_than_usual; Difficulty As_usual ]
585
581
in
586
582
Alcotest.(check int)
587
583
"report time" 60
588
584
(Recovery.timestamp_to_unix_seconds (reported_at feedback));
589
Removed:
Alcotest.(check int) "six signals" 6 (List.length (signals feedback)) );
585
Added:
Alcotest.(check int) "two signals" 2 (List.length (signals feedback)) );
590
586
]
591
587
592
588
let suite =
test/test_import_service.ml
@@ -283,24 +283,24 @@
283
283
let s, t = fixture () in
284
284
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
285
285
(match run (S.progress s t (get "squats")) with
286
Removed:
| Error Progression.Insufficient_data -> ()
286
Added:
| Error Progress.Insufficient_data -> ()
287
287
| _ -> Alcotest.fail "one observation should be insufficient");
288
288
promote_squats s t ~id:"b2" ~ended_at:(day 3) ~kg:105. ~reps:8;
289
289
Alcotest.(check bool)
290
290
"progressing on two imports" true
291
Removed:
(run (S.progress s t (get "squats")) = Ok Progression.Progressing) );
291
Added:
(run (S.progress s t (get "squats")) = Ok Progress.Progressing) );
292
292
( "a flat fortnight of imports reads as a stall",
293
293
`Quick,
294
294
fun () ->
295
295
let s, t = fixture () in
296
296
promote_squats s t ~id:"b1" ~ended_at:(day 10) ~kg:110. ~reps:8;
297
297
(match run (S.progress s t (get "squats")) with
298
Removed:
| Error Progression.Insufficient_data -> ()
298
Added:
| Error Progress.Insufficient_data -> ()
299
299
| _ -> Alcotest.fail "one observation should be insufficient");
300
300
promote_squats s t ~id:"b2" ~ended_at:(day 25) ~kg:110. ~reps:8;
301
301
Alcotest.(check bool)
302
302
"stalled after a flat fortnight" true
303
Removed:
(run (S.progress s t (get "squats")) = Ok Progression.Stalled) );
303
Added:
(run (S.progress s t (get "squats")) = Ok Progress.Stalled) );
304
304
( "imported records for another exercise are excluded",
305
305
`Quick,
306
306
fun () ->
@@ -308,7 +308,7 @@
308
308
promote_squats s t ~id:"b1" ~ended_at:(day 1) ~kg:100. ~reps:8;
309
309
promote_squats s t ~id:"b2" ~ended_at:(day 3) ~kg:105. ~reps:8;
310
310
match run (S.progress s t (get "laterals")) with
311
Removed:
| Error Progression.Insufficient_data -> ()
311
Added:
| Error Progress.Insufficient_data -> ()
312
312
| _ -> Alcotest.fail "laterals should have no evidence" );
313
313
]
314
314
test/test_prescription.ml
@@ -172,6 +172,23 @@
172
172
Alcotest.(check int)
173
173
"four stimuli" 4
174
174
(List.length (Prescription.Workout.stimuli w)) );
175
Added:
( "more than three sets for one muscle is rejected",
176
Added:
`Quick,
177
Added:
fun () ->
178
Added:
let four_curl_sets = List.init 4 (fun _ -> single "curls") in
179
Added:
match
180
Added:
try
181
Added:
ignore
182
Added:
(Prescription.Workout.make ~name:"Too much"
183
Added:
~stimuli:four_curl_sets);
184
Added:
None
185
Added:
with Prescription.Workout.Invalid error -> Some error
186
Added:
with
187
Added:
| Some
188
Added:
(Prescription.Workout.Excess_sets_per_muscle
189
Added:
{ muscle = Exercise.Muscle.Biceps; sets = 4 }) ->
190
Added:
()
191
Added:
| _ -> Alcotest.fail "expected biceps ceiling rejection" );
175
192
( "an empty workout raises Invalid",
176
193
`Quick,
177
194
fun () ->
test/test_progression.ml
@@ -1,4 +1,4 @@
1
Removed:
(** Unit tests for {!Progression}. *)
1
Added:
(** Unit tests for {!Progress}. *)
2
2
3
3
module Stimulus = Evidence.Stimulus
4
4
module Workout = Evidence.Workout
@@ -23,7 +23,7 @@
23
23
Stimulus.Effort.make ~exercise:(get id) ~load:(load load_kg)
24
24
~reps:(reps rep_count) ~outcome
25
25
26
Removed:
(* An observation is the canonical unit Progression judges. *)
26
Added:
(* An observation is the canonical unit Progress judges. *)
27
27
let seen ~on load r : Evidence.Observation.t =
28
28
Evidence.Observation.make ~exercise:(get "laterals") ~effort:(move load r)
29
29
~performed_at:(day on)
@@ -32,53 +32,60 @@
32
32
try
33
33
let _ = f () in
34
34
false
35
Removed:
with Progression.Invalid Progression.Insufficient_data -> true
35
Added:
with Progress.Invalid Progress.Insufficient_data -> true
36
36
37
37
let assess_tests =
38
38
[
39
39
( "the stall window is two weeks",
40
40
`Quick,
41
41
fun () ->
42
Removed:
Alcotest.(check int) "14 days" 1_209_600 (secs Progression.stall_window)
43
Removed:
);
42
Added:
Alcotest.(check int) "14 days" 1_209_600 (secs Progress.stall_window) );
44
43
( "too little record to judge",
45
44
`Quick,
46
45
fun () ->
47
46
Alcotest.(check bool)
48
47
"nothing" true
49
Removed:
(raises_insufficient_data (fun () -> Progression.assess []));
48
Added:
(raises_insufficient_data (fun () -> Progress.assess []));
50
49
Alcotest.(check bool)
51
50
"a single session" true
52
51
(raises_insufficient_data (fun () ->
53
Removed:
Progression.assess [ seen ~on:1 12. 8 ]));
52
Added:
Progress.assess [ seen ~on:1 12. 8 ]));
54
53
Alcotest.(check bool)
55
54
"flat but recent" true
56
55
(raises_insufficient_data (fun () ->
57
Removed:
Progression.assess [ seen ~on:1 12. 8; seen ~on:3 12. 8 ])) );
56
Added:
Progress.assess [ seen ~on:1 12. 8; seen ~on:3 12. 8 ])) );
58
57
( "a recent advance is progress",
59
58
`Quick,
60
59
fun () ->
61
60
Alcotest.(check bool)
62
61
"progressing" true
63
Removed:
(Progression.assess
62
Added:
(Progress.assess
64
63
[ seen ~on:1 12. 8; seen ~on:3 12. 9; seen ~on:5 12. 9 ]
65
Removed:
= Progression.Progressing) );
64
Added:
= Progress.Progressing) );
66
65
( "no advance for two weeks is a stall",
67
66
`Quick,
68
67
fun () ->
69
68
Alcotest.(check bool)
70
69
"stalled" true
71
Removed:
(Progression.assess
70
Added:
(Progress.assess
72
71
[ seen ~on:1 12. 8; seen ~on:8 12. 8; seen ~on:16 12. 8 ]
73
Removed:
= Progression.Stalled) );
72
Added:
= Progress.Stalled) );
74
73
( "an advance more than two weeks ago is also a stall",
75
74
`Quick,
76
75
fun () ->
77
76
Alcotest.(check bool)
78
77
"stalled" true
79
Removed:
(Progression.assess
78
Added:
(Progress.assess
80
79
[ seen ~on:1 12. 8; seen ~on:3 12. 9; seen ~on:20 12. 9 ]
81
Removed:
= Progression.Stalled) );
80
Added:
= Progress.Stalled) );
81
Added:
( "a two-week decline is decompensation",
82
Added:
`Quick,
83
Added:
fun () ->
84
Added:
Alcotest.(check bool)
85
Added:
"decompensating" true
86
Added:
(Progress.assess
87
Added:
[ seen ~on:1 12. 8; seen ~on:8 12. 8; seen ~on:16 10. 7 ]
88
Added:
= Progress.Decompensating) );
82
89
]
83
90
84
91
let remedy_tests =
@@ -88,13 +95,13 @@
88
95
fun () ->
89
96
Alcotest.(check bool)
90
97
"none" true
91
Removed:
(Option.is_none (Progression.remedy Progression.Progressing)) );
98
Added:
(Option.is_none (Progress.remedy Progress.Progressing)) );
92
99
( "a stall calls for a lay-off, then less work and more rest",
93
100
`Quick,
94
101
fun () ->
95
Removed:
match Progression.remedy Progression.Stalled with
102
Added:
match Progress.remedy Progress.Stalled with
96
103
| Some
97
Removed:
(Progression.Lay_off_then_reduce
104
Added:
(Progress.Lay_off_then_reduce
98
105
{ lay_off; drop_stimuli_per_workout; extra_rest }) ->
99
106
Alcotest.(check int) "one week off" 604_800 (secs lay_off);
100
107
Alcotest.(check int)
@@ -105,9 +112,8 @@
105
112
`Quick,
106
113
fun () ->
107
114
(* Structural: the only remedy subtracts. This asserts the intent. *)
108
Removed:
match Progression.remedy Progression.Stalled with
109
Removed:
| Some (Progression.Lay_off_then_reduce { drop_stimuli_per_workout; _ })
110
Removed:
->
115
Added:
match Progress.remedy Progress.Stalled with
116
Added:
| Some (Progress.Lay_off_then_reduce { drop_stimuli_per_workout; _ }) ->
111
117
Alcotest.(check bool)
112
118
"subtracts volume" true
113
119
(drop_stimuli_per_workout > 0)
@@ -118,12 +124,12 @@
118
124
[
119
125
( "the load rises at twelve reps",
120
126
`Quick,
121
Removed:
fun () ->
122
Removed:
Alcotest.(check int) "trigger" 12 Progression.load_increase_trigger );
127
Added:
fun () -> Alcotest.(check int) "trigger" 12 Progress.load_increase_trigger
128
Added:
);
123
129
( "the increase is a 10-20% window",
124
130
`Quick,
125
131
fun () ->
126
Removed:
let low, high = Progression.load_increase ~current:(load 100.) in
132
Added:
let low, high = Progress.load_increase ~current:(load 100.) in
127
133
Alcotest.(check (float 0.001)) "110kg" 110. low;
128
134
Alcotest.(check (float 0.001)) "120kg" 120. high );
129
135
( "inside the window the load holds",
@@ -131,21 +137,21 @@
131
137
fun () ->
132
138
Alcotest.(check bool)
133
139
"8 reps of 6-10" true
134
Removed:
(Progression.judge_load ~rep_range:six_to_ten (move 12. 8)
135
Removed:
= Progression.Hold) );
140
Added:
(Progress.judge_load ~rep_range:six_to_ten (move 12. 8)
141
Added:
= Progress.Hold) );
136
142
( "eleven reps is slack, not yet a load increase",
137
143
`Quick,
138
144
fun () ->
139
145
(* HD1 raises the load at twelve, not merely above the window. *)
140
146
Alcotest.(check bool)
141
147
"11 reps of 6-10 holds" true
142
Removed:
(Progression.judge_load ~rep_range:six_to_ten (move 12. 11)
143
Removed:
= Progression.Hold) );
148
Added:
(Progress.judge_load ~rep_range:six_to_ten (move 12. 11)
149
Added:
= Progress.Hold) );
144
150
( "twelve reps calls for more load",
145
151
`Quick,
146
152
fun () ->
147
Removed:
match Progression.judge_load ~rep_range:six_to_ten (move 100. 12) with
148
Removed:
| Progression.Increase (low, high) ->
153
Added:
match Progress.judge_load ~rep_range:six_to_ten (move 100. 12) with
154
Added:
| Progress.Increase (low, high) ->
149
155
Alcotest.(check (float 0.001)) "110kg" 110. low;
150
156
Alcotest.(check (float 0.001)) "120kg" 120. high
151
157
| _ -> Alcotest.fail "expected Increase" );
@@ -154,8 +160,8 @@
154
160
fun () ->
155
161
Alcotest.(check bool)
156
162
"4 reps of 6-10" true
157
Removed:
(Progression.judge_load ~rep_range:six_to_ten (move 12. 4)
158
Removed:
= Progression.Too_heavy) );
163
Added:
(Progress.judge_load ~rep_range:six_to_ten (move 12. 4)
164
Added:
= Progress.Too_heavy) );
159
165
(* The window's ceiling never gates the verdict: HD1's trigger is the
160
166
absolute twelve, and overshooting a narrower band is the slack it
161
167
allows. Only the floor decides Too_heavy. *)
@@ -164,17 +170,17 @@
164
170
fun () ->
165
171
Alcotest.(check bool)
166
172
"10 reps of 6-8 still holds" true
167
Removed:
(Progression.judge_load ~rep_range:(rep_range 6 8) (move 12. 10)
168
Removed:
= Progression.Hold) );
173
Added:
(Progress.judge_load ~rep_range:(rep_range 6 8) (move 12. 10)
174
Added:
= Progress.Hold) );
169
175
( "the twelve-rep trigger is absolute, whatever the ceiling",
170
176
`Quick,
171
177
fun () ->
172
178
List.iter
173
179
(fun (lo, hi) ->
174
180
match
175
Removed:
Progression.judge_load ~rep_range:(rep_range lo hi) (move 100. 12)
181
Added:
Progress.judge_load ~rep_range:(rep_range lo hi) (move 100. 12)
176
182
with
177
Removed:
| Progression.Increase _ -> ()
183
Added:
| Progress.Increase _ -> ()
178
184
| _ ->
179
185
Alcotest.failf "%d-%d at twelve reps must call for more load" lo
180
186
hi)
@@ -184,12 +190,12 @@
184
190
fun () ->
185
191
Alcotest.(check bool)
186
192
"7 reps of 8-12 is too heavy" true
187
Removed:
(Progression.judge_load ~rep_range:(rep_range 8 12) (move 12. 7)
188
Removed:
= Progression.Too_heavy);
193
Added:
(Progress.judge_load ~rep_range:(rep_range 8 12) (move 12. 7)
194
Added:
= Progress.Too_heavy);
189
195
Alcotest.(check bool)
190
196
"7 reps of 6-10 holds" true
191
Removed:
(Progression.judge_load ~rep_range:six_to_ten (move 12. 7)
192
Removed:
= Progression.Hold) );
197
Added:
(Progress.judge_load ~rep_range:six_to_ten (move 12. 7)
198
Added:
= Progress.Hold) );
193
199
]
194
200
195
201
(* Performed workouts, for the diagnostics. *)
@@ -210,7 +216,7 @@
210
216
let laterals ?outcome load r = stimulus ?outcome "laterals" load r
211
217
212
218
let extended =
213
Removed:
Stimulus.Beyond_failure (Stimulus.Forced_reps, [ Stimulus.Negatives ])
219
Added:
Stimulus.Beyond_failure (Stimulus.Forced_reps 2, [ Stimulus.Negatives 2 ])
214
220
215
221
let diagnostic_tests =
216
222
[
@@ -221,7 +227,7 @@
221
227
Alcotest.(check int)
222
228
"none" 0
223
229
(List.length
224
Removed:
(Progression.diagnose (Evidence.Log.add Evidence.Log.empty w))) );
230
Added:
(Progress.diagnose (Evidence.Log.add Evidence.Log.empty w))) );
225
231
( "extra recorded volume is flagged",
226
232
`Quick,
227
233
fun () ->
@@ -229,9 +235,8 @@
229
235
performed ~clearance:cleared
230
236
~stimuli:[ laterals 12. 8; laterals 12. 6 ]
231
237
in
232
Removed:
match Progression.diagnose (Evidence.Log.add Evidence.Log.empty w) with
233
Removed:
| [ Progression.Excess_volume n ] ->
234
Removed:
Alcotest.(check int) "one workout" 1 n
238
Added:
match Progress.diagnose (Evidence.Log.add Evidence.Log.empty w) with
239
Added:
| [ Progress.Excess_volume n ] -> Alcotest.(check int) "one workout" 1 n
235
240
| _ -> Alcotest.fail "expected the excess-volume diagnostic" );
236
241
( "extending every stimulus is flagged",
237
242
`Quick,
@@ -240,8 +245,8 @@
240
245
performed ~clearance:cleared
241
246
~stimuli:[ laterals ~outcome:extended 12. 8 ]
242
247
in
243
Removed:
match Progression.diagnose (Evidence.Log.add Evidence.Log.empty w) with
244
Removed:
| [ Progression.Extensions_on_every_stimulus n ] ->
248
Added:
match Progress.diagnose (Evidence.Log.add Evidence.Log.empty w) with
249
Added:
| [ Progress.Extensions_on_every_stimulus n ] ->
245
250
Alcotest.(check int) "one workout" 1 n
246
251
| _ -> Alcotest.fail "expected the extension diagnostic" );
247
252
( "extending only some stimuli is not flagged",
@@ -258,7 +263,7 @@
258
263
Alcotest.(check int)
259
264
"none" 0
260
265
(List.length
261
Removed:
(Progression.diagnose (Evidence.Log.add Evidence.Log.empty w))) );
266
Added:
(Progress.diagnose (Evidence.Log.add Evidence.Log.empty w))) );
262
267
( "training on an override is flagged",
263
268
`Quick,
264
269
fun () ->
@@ -271,8 +276,8 @@
271
276
~clearance:(Recovery.override recovering)
272
277
~stimuli:[ laterals 12. 8 ]
273
278
in
274
Removed:
match Progression.diagnose (Evidence.Log.add Evidence.Log.empty w) with
275
Removed:
| [ Progression.Trained_under_recovered n ] ->
279
Added:
match Progress.diagnose (Evidence.Log.add Evidence.Log.empty w) with
280
Added:
| [ Progress.Trained_under_recovered n ] ->
276
281
Alcotest.(check int) "one workout" 1 n
277
282
| _ -> Alcotest.fail "expected the under-recovery diagnostic" );
278
283
( "a stall alongside both habits names both as suspects",
@@ -290,12 +295,12 @@
290
295
Alcotest.(check int)
291
296
"both" 2
292
297
(List.length
293
Removed:
(Progression.diagnose (Evidence.Log.add Evidence.Log.empty w)));
298
Added:
(Progress.diagnose (Evidence.Log.add Evidence.Log.empty w)));
294
299
Alcotest.(check bool)
295
300
"and the routine is stalled" true
296
Removed:
(Progression.assess
301
Added:
(Progress.assess
297
302
[ seen ~on:1 12. 8; seen ~on:8 12. 8; seen ~on:16 12. 8 ]
298
Removed:
= Progression.Stalled) );
303
Added:
= Progress.Stalled) );
299
304
]
300
305
301
306
(* --- per-workout progress count --- *)
@@ -318,7 +323,7 @@
318
323
let w = solo ~on:1 ~load:12. ~r:8 in
319
324
Alcotest.(check int)
320
325
"no progress on the first record" 0
321
Removed:
(Progression.workout_progress (log_of [ w ]) w) );
326
Added:
(Progress.workout_progress (log_of [ w ]) w) );
322
327
( "beating the previous record counts the exercise",
323
328
`Quick,
324
329
fun () ->
@@ -326,7 +331,7 @@
326
331
let second = solo ~on:8 ~load:12. ~r:9 in
327
332
Alcotest.(check int)
328
333
"one exercise progressed" 1
329
Removed:
(Progression.workout_progress (log_of [ first; second ]) second) );
334
Added:
(Progress.workout_progress (log_of [ first; second ]) second) );
330
335
( "matching the previous record is not progress",
331
336
`Quick,
332
337
fun () ->
@@ -334,7 +339,7 @@
334
339
let second = solo ~on:8 ~load:12. ~r:8 in
335
340
Alcotest.(check int)
336
341
"no exercise progressed" 0
337
Removed:
(Progression.workout_progress (log_of [ first; second ]) second) );
342
Added:
(Progress.workout_progress (log_of [ first; second ]) second) );
338
343
( "more load with fewer reps still counts as progress",
339
344
`Quick,
340
345
fun () ->
@@ -342,7 +347,7 @@
342
347
let second = solo ~on:8 ~load:14. ~r:7 in
343
348
Alcotest.(check int)
344
349
"heavier load progressed" 1
345
Removed:
(Progression.workout_progress (log_of [ first; second ]) second) );
350
Added:
(Progress.workout_progress (log_of [ first; second ]) second) );
346
351
]
347
352
348
353
let suite =
test/test_service.ml
@@ -594,7 +594,7 @@
594
594
(List.length (run (S.history s t)));
595
595
Alcotest.(check bool)
596
596
"stalled" true
597
Removed:
(run (S.progress s t (get "laterals")) = Ok Progression.Stalled) );
597
Added:
(run (S.progress s t (get "laterals")) = Ok Progress.Stalled) );
598
598
( "training on overrides shows up as a diagnostic",
599
599
`Quick,
600
600
fun () ->
@@ -609,11 +609,10 @@
609
609
let _ = run (S.finish s t ~ended_at:(day 2)) in
610
610
match
611
611
List.filter
612
Removed:
(function
613
Removed:
| Progression.Trained_under_recovered _ -> true | _ -> false)
612
Added:
(function Progress.Trained_under_recovered _ -> true | _ -> false)
614
613
(run (S.diagnostics s t))
615
614
with
616
Removed:
| [ Progression.Trained_under_recovered n ] ->
615
Added:
| [ Progress.Trained_under_recovered n ] ->
617
616
Alcotest.(check int) "one such workout" 1 n
618
617
| _ -> Alcotest.fail "expected the under-recovery diagnostic" );
619
618
]
test/test_sqlite_repo.ml
@@ -292,8 +292,10 @@
292
292
(run
293
293
(S.record_feedback s id ~reported_at:(day 1)
294
294
[
295
Removed:
Evidence.Feedback.Sleep Evidence.Feedback.Poor;
296
Removed:
Evidence.Feedback.Pain;
295
Added:
Evidence.Feedback.Motivation
296
Added:
Evidence.Feedback.Better_than_usual;
297
Added:
Evidence.Feedback.Difficulty
298
Added:
Evidence.Feedback.As_usual;
297
299
]))
298
300
in
299
301
id
@@ -307,11 +309,15 @@
307
309
let signals = Evidence.Feedback.signals (List.hd reports) in
308
310
Alcotest.(check int) "two signals" 2 (List.length signals);
309
311
Alcotest.(check bool)
310
Removed:
"sleep signal preserved" true
311
Removed:
(List.mem (Evidence.Feedback.Sleep Evidence.Feedback.Poor) signals);
312
Added:
"motivation signal preserved" true
313
Added:
(List.mem
314
Added:
(Evidence.Feedback.Motivation
315
Added:
Evidence.Feedback.Better_than_usual) signals);
312
316
Alcotest.(check bool)
313
Removed:
"pain signal preserved" true
314
Removed:
(List.mem Evidence.Feedback.Pain signals)) );
317
Added:
"difficulty signal preserved" true
318
Added:
(List.mem
319
Added:
(Evidence.Feedback.Difficulty Evidence.Feedback.As_usual)
320
Added:
signals)) );
315
321
( "application feedback survives a reconnect",
316
322
`Quick,
317
323
fun () ->
test/test_web.ml
@@ -764,8 +764,6 @@
764
764
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
765
765
let trainee = the_trainee repo ~username:"lifter" in
766
766
let _ = get c "/logbook?feedback=start" in
767
Removed:
(* Answer sleep (1), skip appetite, answer readiness (3), answer
768
Removed:
motivation (5), skip difficulty. *)
769
767
let step_action step action extra =
770
768
let token = Option.get (csrf_token (body (get c "/logbook"))) in
771
769
post c "/feedback"
@@ -773,42 +771,26 @@
773
771
:: ("step", string_of_int step)
774
772
:: ("action", action) :: extra)
775
773
in
776
Removed:
let s0 = step_action 0 "next" [ ("choice", "1") ] in
777
Removed:
Alcotest.(check int) "first factor redirects" 303 (status s0);
774
Added:
let first = step_action 0 "next" [ ("choice", "better") ] in
775
Added:
Alcotest.(check int) "first factor redirects" 303 (status first);
778
776
let _ = step_action 1 "skip" [] in
779
Removed:
let _ = step_action 2 "next" [ ("choice", "3") ] in
780
Removed:
let _ = step_action 3 "next" [ ("choice", "5") ] in
781
Removed:
let _ = step_action 4 "skip" [] in
782
Removed:
let saved = step_action 5 "save" [ ("pain", "true") ] in
777
Added:
let saved = step_action 2 "save" [] in
783
778
Alcotest.(check int) "final feedback redirects" 303 (status saved);
784
Removed:
(* Exactly one report is stored, holding only the answered signals
785
Removed:
plus pain, and none of the skipped factors. *)
786
779
let reports =
787
780
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
788
781
in
789
782
Alcotest.(check int)
790
783
"one feedback report stored" 1 (List.length reports);
791
Removed:
let signals = Evidence.Feedback.signals (List.hd reports) in
792
Removed:
let has p = List.exists p signals in
793
Removed:
let open Evidence.Feedback in
794
Removed:
Alcotest.(check bool)
795
Removed:
"stored sleep" true
796
Removed:
(has (function Sleep _ -> true | _ -> false));
797
Removed:
Alcotest.(check bool)
798
Removed:
"stored readiness" true
799
Removed:
(has (function Readiness _ -> true | _ -> false));
800
Removed:
Alcotest.(check bool)
801
Removed:
"stored motivation" true
802
Removed:
(has (function Motivation _ -> true | _ -> false));
803
Removed:
Alcotest.(check bool)
804
Removed:
"stored pain" true
805
Removed:
(has (function Pain -> true | _ -> false));
806
Removed:
Alcotest.(check bool)
807
Removed:
"did not store skipped appetite" false
808
Removed:
(has (function Appetite _ -> true | _ -> false));
809
Removed:
Alcotest.(check bool)
810
Removed:
"did not store skipped difficulty" false
811
Removed:
(has (function Difficulty _ -> true | _ -> false)) );
784
Added:
let signal_list = Evidence.Feedback.signals (List.hd reports) in
785
Added:
Alcotest.(check (list bool))
786
Added:
"only motivation stored" [ true ]
787
Added:
(List.map
788
Added:
(function
789
Added:
| Evidence.Feedback.Motivation
790
Added:
Evidence.Feedback.Better_than_usual ->
791
Added:
true
792
Added:
| _ -> false)
793
Added:
signal_list) );
812
794
( "skipping the entire feedback flow records nothing",
813
795
`Quick,
814
796
fun () ->
@@ -838,27 +820,27 @@
838
820
:: ("step", string_of_int step)
839
821
:: ("action", action) :: extra)
840
822
in
841
Removed:
(* Answer sleep (5), move to appetite, go back, then skip forward to
842
Removed:
notes and save. The pre-back sleep answer must survive. *)
843
Removed:
let _ = step_action 0 "next" [ ("choice", "5") ] in
823
Added:
(* Answer motivation, move to difficulty, return, then skip
824
Added:
motivation and difficulty before saving. The earlier motivation
825
Added:
answer remains in the flow. *)
826
Added:
let _ = step_action 0 "next" [ ("choice", "better") ] in
844
827
let back = step_action 1 "back" [] in
845
828
Alcotest.(check int) "back redirects" 303 (status back);
846
829
let _ = step_action 0 "skip" [] in
847
830
let _ = step_action 1 "skip" [] in
848
Removed:
let _ = step_action 2 "skip" [] in
849
Removed:
let _ = step_action 3 "skip" [] in
850
Removed:
let _ = step_action 4 "skip" [] in
851
Removed:
let _ = step_action 5 "save" [] in
831
Added:
let _ = step_action 2 "save" [] in
852
832
let reports =
853
833
Lwt_main.run (Memory_repo.feedback repo trainee.Trainee.id)
854
834
in
855
835
Alcotest.(check int) "one report stored" 1 (List.length reports);
856
836
let signals = Evidence.Feedback.signals (List.hd reports) in
857
837
Alcotest.(check bool)
858
Removed:
"the pre-back sleep answer persists" true
838
Added:
"the pre-back motivation answer persists" true
859
839
(List.exists
860
840
(function
861
Removed:
| Evidence.Feedback.Sleep Evidence.Feedback.Very_good -> true
841
Added:
| Evidence.Feedback.Motivation
842
Added:
Evidence.Feedback.Better_than_usual ->
843
Added:
true
862
844
| _ -> false)
863
845
signals) );
864
846
( "closing the feedback modal discards the flow",
@@ -875,7 +857,7 @@
875
857
("dream.csrf", token);
876
858
("step", "0");
877
859
("action", "next");
878
Removed:
("choice", "5");
860
Added:
("choice", "better");
879
861
]
880
862
in
881
863
let appetite = body (get c "/logbook") in
@@ -1663,15 +1645,13 @@
1663
1645
`Quick,
1664
1646
fun () ->
1665
1647
(* The flow admits one answer per factor, so the stored report holds
1666
Removed:
one signal per category and never a duplicate. Walking all five
1667
Removed:
factors and saving proves the whole set persists without a
1668
Removed:
duplicate-signal rejection. *)
1648
Added:
one signal per category and never a duplicate. *)
1669
1649
let c, repo = client_with_repo () in
1670
1650
let _ = register c ~username:"lifter" ~password:"heavyduty1" in
1671
1651
let trainee = the_trainee repo ~username:"lifter" in
1672
1652
let _ = get c "/logbook?feedback=start" in
1673
1653
let rec advance step =
1674
Removed:
if step < 5 then begin
1654
Added:
if step < 2 then begin
1675
1655
let token = Option.get (csrf_token (body (get c "/logbook"))) in
1676
1656
let _ =
1677
1657
post c "/feedback"
@@ -1679,7 +1659,7 @@
1679
1659
("dream.csrf", token);
1680
1660
("step", string_of_int step);
1681
1661
("action", "next");
1682
Removed:
("choice", "1");
1662
Added:
("choice", "worse");
1683
1663
]
1684
1664
in
1685
1665
advance (step + 1)
@@ -1689,7 +1669,7 @@
1689
1669
let token = Option.get (csrf_token (body (get c "/logbook"))) in
1690
1670
let saved =
1691
1671
post c "/feedback"
1692
Removed:
[ ("dream.csrf", token); ("step", "5"); ("action", "save") ]
1672
Added:
[ ("dream.csrf", token); ("step", "2"); ("action", "save") ]
1693
1673
in
1694
1674
Alcotest.(check int) "final save redirects" 303 (status saved);
1695
1675
(* Exactly one report, with one signal per distinct factor. *)
@@ -1700,15 +1680,6 @@
1700
1680
let signals = Evidence.Feedback.signals (List.hd reports) in
1701
1681
let count p = List.length (List.filter p signals) in
1702
1682
let open Evidence.Feedback in
1703
Removed:
Alcotest.(check int)
1704
Removed:
"one sleep signal" 1
1705
Removed:
(count (function Sleep _ -> true | _ -> false));
1706
Removed:
Alcotest.(check int)
1707
Removed:
"one appetite signal" 1
1708
Removed:
(count (function Appetite _ -> true | _ -> false));
1709
Removed:
Alcotest.(check int)
1710
Removed:
"one readiness signal" 1
1711
Removed:
(count (function Readiness _ -> true | _ -> false));
1712
1683
Alcotest.(check int)
1713
1684
"one motivation signal" 1
1714
1685
(count (function Motivation _ -> true | _ -> false));