[OCaml] High Intensity Training Online
feat Support recorded set corrections
Replace a recorded prescription slot in place so corrections do not add workout volume.
Changed files
ARCHITECTURE.md
@@ -79,7 +79,14 @@
79
79
to a continuation, so a route with any number of path captures shares one
80
80
gate. Every domain and service error becomes a user-facing sentence in one
81
81
`Present` module, so a handler renders a message rather than choosing its
82
Removed:
wording.
82
Added:
wording. The workout view — the same page for the workout in progress and a
83
Added:
saved history record — shows one prescribed slot at a time under a strip of
84
Added:
named tabs. Each tab is a server-rendered link that carries its slot in a
85
Added:
`?slot=` query parameter, so the view is deterministic route state with no
86
Added:
client script; the active link is marked with `aria-current="page"`. A
87
Added:
handler clamps a requested slot against the prescription and otherwise opens
88
Added:
on the default: the first slot still awaiting a record, or the first slot
89
Added:
when every slot is filled.
83
90
84
91
### Accounts, sessions, and storage
85
92
@@ -105,8 +112,11 @@
105
112
a file from an earlier, ledger-less build stays safe.
106
113
- **Codec** — the serialization boundary. It captures only what was performed
107
114
and rebuilds a `Evidence.Workout.t` by driving the same core constructors a
108
Removed:
live session does. A prescription is not stored; it is found again by name in
109
Removed:
the `Catalog`. This keeps the core unchanged and carries no serializers.
115
Added:
live session does. Each stored stimulus carries the prescription slot it
116
Added:
filled, so a corrected or out-of-order record replays into the same slot; a
117
Added:
record from before slots were stored replays in performance order instead. A
118
Added:
prescription is not stored; it is found again by name in the `Catalog`. This
119
Added:
keeps the core unchanged and carries no serializers.
110
120
- **Authentication** — `Handlers` verifies a local username and password, then
111
121
stores the trainee id in a signed session. Every application route requires
112
122
an authenticated trainee and redirects to the sign-in page otherwise. Every
@@ -150,7 +160,9 @@
150
160
and carry no outcome, so a warm-up cannot reach failure by type.
151
161
- **Entry** — a workout performed against its prescription. Starting one requires
152
162
a clearance; adding a stimulus requires that the prescription actually calls
153
Removed:
for it.
163
Added:
for it. `add_stimulus` fills the next matching slot or records extra volume;
164
Added:
`replace_stimulus ~slot` corrects one slot in place, and `record_at ~slot` is
165
Added:
the faithful-replay primitive the codec uses. A correction is not extra work.
154
166
- **Logbook** — every entry, plus the questions history answers: what was
155
167
performed last, how long since the last finished workout, and what an effort
156
168
has done over time. Evidence is dated, because a stall is defined by two weeks
@@ -240,10 +252,12 @@
240
252
| `/workout` | GET | The workout in progress |
241
253
| `/workout` | POST | Start the next workout or refuse at the recovery gate |
242
254
| `/workout/slots/:slot` | POST | Record one prescribed stimulus |
255
Added:
| `/workout/slots/:slot/edit`| POST | Correct a recorded slot (replaces it, adds no volume) |
243
256
| `/workout/finish` | POST | Complete and persist |
244
257
| `/history` | GET | What has been performed |
245
258
| `/history/:id` | GET | View a saved workout and its missing records |
246
259
| `/history/:id/slots/:slot` | POST | Add a missing saved record |
260
Added:
| `/history/:id/slots/:slot/edit` | POST | Correct a recorded slot of a saved workout |
247
261
248
262
Dream permits nested resource paths, so slot and record identity live in the
249
263
path rather than hidden fields or query parameters.
@@ -285,7 +299,12 @@
285
299
**Extra volume is recordable.** HD1 forbids it in the strongest terms, but a log
286
300
that refuses to state what happened is worse than one that records an error. The
287
301
constraint lives on the prescription side, which cannot prescribe extra work;
288
Removed:
performing extra shows as more stimuli than slots.
302
Added:
performing extra shows as more stimuli than slots. A correction is distinct from
303
Added:
extra volume: `Evidence.Workout.replace_stimulus ~slot` targets one slot and
304
Added:
replaces its record, so fixing a mistyped load never counts as another set. The
305
Added:
web edit forms and the `.../slots/:slot/edit` routes drive this API, and the
306
Added:
completion count (`filled_slots`) counts distinct answered slots, so a correction
307
Added:
never advances or inflates it.
289
308
290
309
**Extension rarity is a diagnostic, not an invariant.** Same reason: HD1 says
291
310
never to extend every exercise of a workout, but if you did, the record must say
lib/app/codec.ml
@@ -66,12 +66,12 @@
66
66
(Evidence.Stimulus.Effort.reps effort)
67
67
(encode_outcome (Evidence.Stimulus.Effort.outcome effort))
68
68
69
Removed:
let encode_stimulus stimulus =
69
Added:
let encode_stimulus ~slot stimulus =
70
70
match Evidence.Stimulus.delivery stimulus with
71
71
| Evidence.Stimulus.Single effort ->
72
Removed:
Printf.sprintf "stimulus\tsingle\t%s" (encode_effort effort)
72
Added:
Printf.sprintf "stimulus\t%d\tsingle\t%s" slot (encode_effort effort)
73
73
| Evidence.Stimulus.Pair { first; second } ->
74
Removed:
Printf.sprintf "stimulus\tpair\t%s\t%s" (encode_effort first)
74
Added:
Printf.sprintf "stimulus\t%d\tpair\t%s\t%s" slot (encode_effort first)
75
75
(encode_effort second)
76
76
77
77
let ( let* ) = Result.bind
@@ -88,19 +88,32 @@
88
88
| _ -> Error (Malformed "effort load/reps")))
89
89
| _ -> Error (Malformed "effort arity")
90
90
91
Added:
(* Decode a stimulus and the slot it filled. The current format prefixes the
92
Added:
slot; a record from before slots were stored omits it, and replays in
93
Added:
performance order through [add_stimulus] instead. *)
91
94
let decode_stimulus fields =
95
Added:
let delivery = function
96
Added:
| "single" :: rest ->
97
Added:
let* effort = decode_effort rest in
98
Added:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort))
99
Added:
| "pair" :: rest -> (
100
Added:
match rest with
101
Added:
| [ a; b; c; d; e; f; g; h ] ->
102
Added:
let* first = decode_effort [ a; b; c; d ] in
103
Added:
let* second = decode_effort [ e; f; g; h ] in
104
Added:
Ok
105
Added:
(Evidence.Stimulus.make
106
Added:
(Evidence.Stimulus.Pair { first; second }))
107
Added:
| _ -> Error (Malformed "pair arity"))
108
Added:
| _ -> Error (Malformed "stimulus delivery")
109
Added:
in
92
110
match fields with
93
Removed:
| "single" :: rest ->
94
Removed:
let* effort = decode_effort rest in
95
Removed:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort))
96
Removed:
| "pair" :: rest -> (
97
Removed:
match rest with
98
Removed:
| [ a; b; c; d; e; f; g; h ] ->
99
Removed:
let* first = decode_effort [ a; b; c; d ] in
100
Removed:
let* second = decode_effort [ e; f; g; h ] in
101
Removed:
Ok (Evidence.Stimulus.make (Evidence.Stimulus.Pair { first; second }))
102
Removed:
| _ -> Error (Malformed "pair arity"))
103
Removed:
| _ -> Error (Malformed "stimulus delivery")
111
Added:
| slot :: rest when Option.is_some (int_of_string_opt slot) ->
112
Added:
let* stimulus = delivery rest in
113
Added:
Ok (Some (Option.get (int_of_string_opt slot)), stimulus)
114
Added:
| rest ->
115
Added:
let* stimulus = delivery rest in
116
Added:
Ok (None, stimulus)
104
117
105
118
(* --- clearance --- *)
106
119
@@ -161,8 +174,8 @@
161
174
(Printf.sprintf "ended\t%d" (Recovery.timestamp_to_unix_seconds ended))
162
175
| None -> ());
163
176
List.iter
164
Removed:
(fun stimulus -> line (encode_stimulus stimulus))
165
Removed:
(Evidence.Workout.stimuli workout);
177
Added:
(fun (slot, stimulus) -> line (encode_stimulus ~slot stimulus))
178
Added:
(Evidence.Workout.performed workout);
166
179
Buffer.contents buf
167
180
168
181
(* A fully-parsed header, gathered before any replay. Parsing produces this
@@ -174,7 +187,8 @@
174
187
clearance : Recovery.clearance;
175
188
started_at : Recovery.timestamp;
176
189
ended_at : Recovery.timestamp option;
177
Removed:
stimuli : Evidence.Stimulus.t list; (** Performance order. *)
190
Added:
stimuli : (int option * Evidence.Stimulus.t) list;
191
Added:
(** Performance order, each with the slot it filled when known. *)
178
192
}
179
193
180
194
(* Fields accumulated while folding over lines; every field is optional until
@@ -186,7 +200,7 @@
186
200
a_clearance : Recovery.clearance option;
187
201
a_started : Recovery.timestamp option;
188
202
a_ended : Recovery.timestamp option;
189
Removed:
a_stimuli_rev : Evidence.Stimulus.t list;
203
Added:
a_stimuli_rev : (int option * Evidence.Stimulus.t) list;
190
204
}
191
205
192
206
let empty_acc =
@@ -281,7 +295,12 @@
281
295
~started_at:parsed.started_at
282
296
in
283
297
let workout =
284
Removed:
List.fold_left Evidence.Workout.add_stimulus workout parsed.stimuli
298
Added:
List.fold_left
299
Added:
(fun workout (slot, stimulus) ->
300
Added:
match slot with
301
Added:
| Some slot -> Evidence.Workout.record_at workout ~slot stimulus
302
Added:
| None -> Evidence.Workout.add_stimulus workout stimulus)
303
Added:
workout parsed.stimuli
285
304
in
286
305
let workout =
287
306
match parsed.ended_at with
lib/app/service.ml
@@ -143,6 +143,17 @@
143
143
| exception Evidence.Workout.Invalid error ->
144
144
Lwt.return (Error (Rejected error)))
145
145
146
Added:
let replace_current t trainee ~slot stimulus =
147
Added:
R.in_progress t.repo trainee >>= function
148
Added:
| None -> Lwt.return (Error No_workout_in_progress)
149
Added:
| Some workout -> (
150
Added:
match Evidence.Workout.replace_stimulus workout ~slot stimulus with
151
Added:
| updated ->
152
Added:
R.set_in_progress t.repo trainee (Some updated) >|= fun () ->
153
Added:
Ok updated
154
Added:
| exception Evidence.Workout.Invalid error ->
155
Added:
Lwt.return (Error (Rejected error)))
156
Added:
146
157
let finish t trainee ~ended_at =
147
158
R.in_progress t.repo trainee >>= function
148
159
| None -> Lwt.return None
@@ -170,6 +181,22 @@
170
181
| exception Evidence.Workout.Invalid error ->
171
182
Lwt.return (Error (Rejected_edit error)))
172
183
184
Added:
let replace_in_record t trainee id ~slot stimulus =
185
Added:
R.find t.repo trainee id >>= function
186
Added:
| None -> Lwt.return (Error Unknown_workout)
187
Added:
| Some record -> (
188
Added:
match
189
Added:
Evidence.Workout.replace_stimulus record.Repository.workout ~slot
190
Added:
stimulus
191
Added:
with
192
Added:
| workout ->
193
Added:
R.replace t.repo trainee { record with Repository.workout }
194
Added:
>|= fun replaced ->
195
Added:
if replaced then Ok { record with Repository.workout }
196
Added:
else Error Unknown_workout
197
Added:
| exception Evidence.Workout.Invalid error ->
198
Added:
Lwt.return (Error (Rejected_edit error)))
199
Added:
173
200
let history t trainee = R.history t.repo trainee
174
201
end
175
202
@@ -198,9 +225,11 @@
198
225
let begin_workout = Workouts.begin_workout
199
226
let in_progress = Workouts.in_progress
200
227
let log = Workouts.log
228
Added:
let replace_current = Workouts.replace_current
201
229
let finish = Workouts.finish
202
230
let find_record = Records.find_record
203
231
let add_to_record = Records.add_to_record
232
Added:
let replace_in_record = Records.replace_in_record
204
233
let history = Records.history
205
234
let progress = Assessment.progress
206
235
let diagnostics = Assessment.diagnostics
lib/app/service.mli
@@ -98,6 +98,15 @@
98
98
(Evidence.Workout.t, log_error) result Lwt.t
99
99
(** Record a stimulus against the workout in progress. *)
100
100
101
Added:
val replace_current :
102
Added:
t ->
103
Added:
Trainee.id ->
104
Added:
slot:int ->
105
Added:
Evidence.Stimulus.t ->
106
Added:
(Evidence.Workout.t, log_error) result Lwt.t
107
Added:
(** Correct a recorded slot of the workout in progress. Replaces the slot's
108
Added:
record rather than adding volume. *)
109
Added:
101
110
val finish :
102
111
t ->
103
112
Trainee.id ->
@@ -117,6 +126,16 @@
117
126
Repository.workout_id ->
118
127
Evidence.Stimulus.t ->
119
128
(Repository.record, edit_error) result Lwt.t
129
Added:
130
Added:
val replace_in_record :
131
Added:
t ->
132
Added:
Trainee.id ->
133
Added:
Repository.workout_id ->
134
Added:
slot:int ->
135
Added:
Evidence.Stimulus.t ->
136
Added:
(Repository.record, edit_error) result Lwt.t
137
Added:
(** Correct a recorded slot of a saved workout. Replaces the slot's record
138
Added:
rather than adding volume. *)
120
139
121
140
val history : t -> Trainee.id -> Repository.record list Lwt.t
122
141
lib/core/evidence.ml
@@ -125,6 +125,7 @@
125
125
prescribed : shape;
126
126
logged : shape;
127
127
}
128
Added:
| No_such_slot of int
128
129
129
130
exception Invalid of error
130
131
@@ -148,6 +149,8 @@
148
149
Format.fprintf ppf "%s is prescribed as %a but was logged as %a"
149
150
(exercise :> string)
150
151
pp_shape prescribed pp_shape logged
152
Added:
| No_such_slot slot ->
153
Added:
Format.fprintf ppf "slot %d is not part of this workout" slot
151
154
152
155
let start prescription ~clearance ~started_at =
153
156
{ prescription; clearance; started_at; ended_at = None; performed = [] }
@@ -158,6 +161,7 @@
158
161
let ended_at t = t.ended_at
159
162
let is_finished t = Option.is_some t.ended_at
160
163
let stimuli t = List.map snd (List.rev t.performed)
164
Added:
let performed t = List.rev t.performed
161
165
162
166
let duration t =
163
167
Option.map
@@ -204,6 +208,10 @@
204
208
let unperformed t = List.map snd (outstanding t)
205
209
let completeness t = if outstanding t = [] then Complete else Incomplete
206
210
211
Added:
(* Distinct answered slots, so recorded extra volume never inflates the
212
Added:
count past the prescription length. *)
213
Added:
let filled_slots t = List.length (List.sort_uniq Int.compare (answered t))
214
Added:
207
215
let add_stimulus t s =
208
216
let candidates = List.filter (fun (_, p) -> mentions p s) (indexed t) in
209
217
let matching = List.filter (fun (_, p) -> conforms p s) candidates in
@@ -227,6 +235,51 @@
227
235
match unanswered with chosen :: _ -> chosen | [] -> List.hd matching
228
236
in
229
237
{ t with performed = (i, s) :: t.performed }
238
Added:
239
Added:
(* Validate a stimulus against one named slot, raising as [add_stimulus]
240
Added:
does. Shared by the slot-targeted operations. *)
241
Added:
let prescription_at t slot =
242
Added:
match List.nth_opt (Prescription.Workout.stimuli t.prescription) slot with
243
Added:
| Some p -> p
244
Added:
| None -> raise (Invalid (No_such_slot slot))
245
Added:
246
Added:
let check_against p s =
247
Added:
if not (mentions p s) then
248
Added:
raise
249
Added:
(Invalid (Not_prescribed (Exercise.id (List.hd (Stimulus.exercises s)))))
250
Added:
else if not (conforms p s) then
251
Added:
raise
252
Added:
(Invalid
253
Added:
(Delivery_mismatch
254
Added:
{
255
Added:
exercise = Exercise.id (List.hd (Stimulus.exercises s));
256
Added:
prescribed = prescribed_shape p;
257
Added:
logged = logged_shape s;
258
Added:
}))
259
Added:
260
Added:
let record_at t ~slot s =
261
Added:
check_against (prescription_at t slot) s;
262
Added:
{ t with performed = (slot, s) :: t.performed }
263
Added:
264
Added:
let replace_stimulus t ~slot s =
265
Added:
check_against (prescription_at t slot) s;
266
Added:
(* A correction targets the slot; it never adds to the recorded volume.
267
Added:
Replace the slot's fill in place, keeping its position in performance
268
Added:
order. When the slot was empty, record it as its first fill. *)
269
Added:
if List.mem_assoc slot t.performed then
270
Added:
let replaced = ref false in
271
Added:
let performed =
272
Added:
List.map
273
Added:
(fun (i, existing) ->
274
Added:
if i = slot && not !replaced then begin
275
Added:
replaced := true;
276
Added:
(i, s)
277
Added:
end
278
Added:
else (i, existing))
279
Added:
t.performed
280
Added:
in
281
Added:
{ t with performed }
282
Added:
else { t with performed = (slot, s) :: t.performed }
230
283
231
284
let finish t ~ended_at =
232
285
match t.ended_at with
lib/core/evidence.mli
@@ -85,6 +85,9 @@
85
85
prescribed : shape;
86
86
logged : shape;
87
87
}
88
Added:
| No_such_slot of int
89
Added:
(** A slot-targeted operation named a slot the prescription does not
90
Added:
have. *)
88
91
89
92
val pp_error : Format.formatter -> error -> unit
90
93
@@ -97,9 +100,17 @@
97
100
t
98
101
99
102
val add_stimulus : t -> Stimulus.t -> t
100
Removed:
(** Raises [Invalid] when the stimulus does not conform to the prescription.
101
Removed:
*)
103
Added:
(** Records against the next matching unanswered slot, or as extra volume when
104
Added:
every matching slot is already answered. Raises [Invalid] when the
105
Added:
stimulus does not conform to any prescribed slot. *)
102
106
107
Added:
val replace_stimulus : t -> slot:int -> Stimulus.t -> t
108
Added:
(** Records the stimulus into a named prescription slot, replacing whatever
109
Added:
filled that slot before. A correction, not extra work: it targets the slot
110
Added:
and never appends volume. The stimulus must conform to that slot's
111
Added:
prescription. Raises [Invalid (No_such_slot _)] for an unknown slot, and
112
Added:
[Invalid] for a stimulus the slot does not call for. *)
113
Added:
103
114
val finish : t -> ended_at:Recovery.timestamp -> t
104
115
(** Sets [ended_at] once; later calls retain the first value. *)
105
116
@@ -113,6 +124,22 @@
113
124
114
125
val stimuli : t -> Stimulus.t list
115
126
(** Performance order. *)
127
Added:
128
Added:
val performed : t -> (int * Stimulus.t) list
129
Added:
(** Each recorded stimulus paired with the prescription slot it filled, in
130
Added:
performance order. A slot appears more than once only when extra volume
131
Added:
was recorded against it. *)
132
Added:
133
Added:
val record_at : t -> slot:int -> Stimulus.t -> t
134
Added:
(** Append a stimulus at a named slot, preserving any prior fill of that slot.
135
Added:
The faithful-replay primitive: it reconstructs {!performed} verbatim,
136
Added:
including recorded extra volume, without the slot-clearing that
137
Added:
{!replace_stimulus} performs. Validates the stimulus against the slot and
138
Added:
raises [Invalid] as {!replace_stimulus} does. *)
139
Added:
140
Added:
val filled_slots : t -> int
141
Added:
(** How many distinct prescription slots have a record. Never exceeds the
142
Added:
prescription length, even when extra volume was recorded. *)
116
143
117
144
val outstanding : t -> (int * Prescription.Stimulus.t) list
118
145
val unperformed : t -> Prescription.Stimulus.t list
test/test_codec.ml
@@ -132,6 +132,29 @@
132
132
match Codec.decode_workout ~find_routine encoded with
133
133
| Error (Codec.Malformed _) -> ()
134
134
| _ -> Alcotest.fail "expected Malformed for missing fields" );
135
Added:
( "a corrected slot round-trips, preserving the slot mapping",
136
Added:
`Quick,
137
Added:
fun () ->
138
Added:
(* Fill slot 1, then correct it: replace, not append. The encoding
139
Added:
carries the slot, so replay reproduces one filled slot, not two. *)
140
Added:
let day_one =
141
Added:
List.hd (Prescription.Routine.workouts Prescription.Routine.ideal)
142
Added:
in
143
Added:
let clearance = Option.get (Recovery.clear Recovery.Ready) in
144
Added:
let w = Workout.start day_one ~clearance ~started_at:(at 100) in
145
Added:
let w = Workout.add_stimulus w (single "laterals" 12. 8) in
146
Added:
let w = Workout.replace_stimulus w ~slot:1 (single "laterals" 14. 7) in
147
Added:
let d = roundtrip w in
148
Added:
Alcotest.(check int)
149
Added:
"one filled slot survives" 1 (Workout.filled_slots d);
150
Added:
Alcotest.(check (list int))
151
Added:
"same slot mapping"
152
Added:
(List.map fst (Workout.performed w))
153
Added:
(List.map fst (Workout.performed d));
154
Added:
Alcotest.(check (float 0.001))
155
Added:
"corrected load survives" 14.
156
Added:
(Stimulus.Effort.load
157
Added:
(List.hd (Stimulus.efforts (List.hd (Workout.stimuli d))))) );
135
158
]
136
159
137
160
let suite = [ ("codec", codec_tests) ]
test/test_evidence.ml
@@ -268,6 +268,86 @@
268
268
);
269
269
]
270
270
271
Added:
let editing_tests =
272
Added:
[
273
Added:
( "replace_stimulus corrects a slot in place without adding volume",
274
Added:
`Quick,
275
Added:
fun () ->
276
Added:
let w = perform [ single "laterals" 12. 8 ] in
277
Added:
Alcotest.(check int) "one filled slot" 1 (Workout.filled_slots w);
278
Added:
let w = Workout.replace_stimulus w ~slot:1 (single "laterals" 14. 7) in
279
Added:
Alcotest.(check int) "still one filled slot" 1 (Workout.filled_slots w);
280
Added:
Alcotest.(check int)
281
Added:
"still one stimulus" 1
282
Added:
(List.length (Workout.stimuli w));
283
Added:
match Workout.stimuli w with
284
Added:
| [ s ] ->
285
Added:
Alcotest.(check (float 0.001))
286
Added:
"corrected load" 14.
287
Added:
(Stimulus.Effort.load (List.hd (Stimulus.efforts s)))
288
Added:
| _ -> Alcotest.fail "expected one stimulus" );
289
Added:
( "replace_stimulus fills an empty slot as its first record",
290
Added:
`Quick,
291
Added:
fun () ->
292
Added:
let w =
293
Added:
Workout.replace_stimulus (fresh ()) ~slot:1 (single "laterals" 12. 8)
294
Added:
in
295
Added:
Alcotest.(check int) "one filled slot" 1 (Workout.filled_slots w);
296
Added:
Alcotest.(check int)
297
Added:
"three slots still outstanding" 3
298
Added:
(List.length (Workout.unperformed w)) );
299
Added:
( "replace_stimulus rejects an unknown slot",
300
Added:
`Quick,
301
Added:
fun () ->
302
Added:
match
303
Added:
invalid_error (fun () ->
304
Added:
Workout.replace_stimulus (fresh ()) ~slot:9
305
Added:
(single "laterals" 12. 8))
306
Added:
with
307
Added:
| Some (Workout.No_such_slot 9) -> ()
308
Added:
| _ -> Alcotest.fail "expected No_such_slot" );
309
Added:
( "replace_stimulus rejects a stimulus the slot does not call for",
310
Added:
`Quick,
311
Added:
fun () ->
312
Added:
(* Slot 0 is the pre-exhaust pair; a lone set does not fit its shape. *)
313
Added:
match
314
Added:
invalid_error (fun () ->
315
Added:
Workout.replace_stimulus (fresh ()) ~slot:0
316
Added:
(single "dumbbell-flyes" 20. 9))
317
Added:
with
318
Added:
| Some (Workout.Delivery_mismatch _) -> ()
319
Added:
| Some _ | None -> Alcotest.fail "expected Delivery_mismatch" );
320
Added:
( "filled_slots never exceeds the prescription despite extra volume",
321
Added:
`Quick,
322
Added:
fun () ->
323
Added:
let w = perform [ single "laterals" 12. 8; single "laterals" 12. 6 ] in
324
Added:
Alcotest.(check int)
325
Added:
"two stimuli recorded" 2
326
Added:
(List.length (Workout.stimuli w));
327
Added:
Alcotest.(check int) "but one slot filled" 1 (Workout.filled_slots w) );
328
Added:
( "record_at appends at a slot, preserving prior fills",
329
Added:
`Quick,
330
Added:
fun () ->
331
Added:
let w =
332
Added:
Workout.record_at (fresh ()) ~slot:1 (single "laterals" 12. 8)
333
Added:
in
334
Added:
let w = Workout.record_at w ~slot:1 (single "laterals" 12. 6) in
335
Added:
Alcotest.(check int)
336
Added:
"two records at the slot" 2
337
Added:
(List.length (Workout.performed w));
338
Added:
Alcotest.(check int)
339
Added:
"still one distinct slot" 1 (Workout.filled_slots w) );
340
Added:
( "performed pairs each stimulus with its slot",
341
Added:
`Quick,
342
Added:
fun () ->
343
Added:
let w =
344
Added:
perform [ single "laterals" 12. 8; single "bent-over-laterals" 10. 9 ]
345
Added:
in
346
Added:
Alcotest.(check (list int))
347
Added:
"slots 1 then 2" [ 1; 2 ]
348
Added:
(List.map fst (Workout.performed w)) );
349
Added:
]
350
Added:
271
351
let clearance_tests =
272
352
[
273
353
( "a workout keeps the basis on which it was begun",
@@ -494,6 +574,7 @@
494
574
("evidence.workout.lifecycle", lifecycle_tests);
495
575
("evidence.workout.conformance", conformance_tests);
496
576
("evidence.workout.volume", volume_tests);
577
Added:
("evidence.workout.editing", editing_tests);
497
578
("evidence.workout.clearance", clearance_tests);
498
579
("evidence.workout.completion_feedback", completion_feedback_tests);
499
580
("evidence.log.basics", log_basic_tests);
test/test_service.ml
@@ -369,6 +369,66 @@
369
369
"original end" 120
370
370
(Recovery.timestamp_to_unix_seconds
371
371
(Option.get (Workout.ended_at record.Repository.workout))) );
372
Added:
( "replace_current corrects a recorded slot without adding volume",
373
Added:
`Quick,
374
Added:
fun () ->
375
Added:
let s, t = fixture () in
376
Added:
ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())));
377
Added:
ignore (ok (run (S.log s t (single "laterals" 12. 8))));
378
Added:
let w =
379
Added:
ok (run (S.replace_current s t ~slot:1 (single "laterals" 14. 7)))
380
Added:
in
381
Added:
Alcotest.(check int)
382
Added:
"still one stimulus" 1
383
Added:
(List.length (Workout.stimuli w));
384
Added:
Alcotest.(check int) "one filled slot" 1 (Workout.filled_slots w);
385
Added:
Alcotest.(check (float 0.001))
386
Added:
"corrected load" 14.
387
Added:
(Stimulus.Effort.load
388
Added:
(List.hd (Stimulus.efforts (List.hd (Workout.stimuli w))))) );
389
Added:
( "replace_current rejects a stimulus the slot does not call for",
390
Added:
`Quick,
391
Added:
fun () ->
392
Added:
let s, t = fixture () in
393
Added:
ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())));
394
Added:
match run (S.replace_current s t ~slot:1 (single "shrugs" 80. 10)) with
395
Added:
| Error (S.Rejected _) -> ()
396
Added:
| _ -> Alcotest.fail "expected Rejected" );
397
Added:
( "replace_in_record corrects a saved slot without adding volume",
398
Added:
`Quick,
399
Added:
fun () ->
400
Added:
let s, t = fixture () in
401
Added:
ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())));
402
Added:
ignore (ok (run (S.log s t (single "laterals" 12. 8))));
403
Added:
let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in
404
Added:
let record =
405
Added:
ok
406
Added:
(run
407
Added:
(S.replace_in_record s t record.Repository.id ~slot:1
408
Added:
(single "laterals" 16. 6)))
409
Added:
in
410
Added:
Alcotest.(check int)
411
Added:
"still one stimulus" 1
412
Added:
(List.length (Workout.stimuli record.Repository.workout));
413
Added:
Alcotest.(check (float 0.001))
414
Added:
"corrected load" 16.
415
Added:
(Stimulus.Effort.load
416
Added:
(List.hd
417
Added:
(Stimulus.efforts
418
Added:
(List.hd (Workout.stimuli record.Repository.workout))))) );
419
Added:
( "replace_in_record rejects an unknown slot",
420
Added:
`Quick,
421
Added:
fun () ->
422
Added:
let s, t = fixture () in
423
Added:
ignore (ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ())));
424
Added:
let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in
425
Added:
match
426
Added:
run
427
Added:
(S.replace_in_record s t record.Repository.id ~slot:99
428
Added:
(single "laterals" 12. 8))
429
Added:
with
430
Added:
| Error (S.Rejected_edit (Workout.No_such_slot 99)) -> ()
431
Added:
| _ -> Alcotest.fail "expected Rejected_edit No_such_slot" );
372
432
]
373
433
374
434
let assessment_tests =
test/test_sqlite_repo.ml
@@ -136,6 +136,45 @@
136
136
Alcotest.(check int)
137
137
"one stimulus survived" 1
138
138
(List.length (Workout.stimuli reread.Repository.workout))) );
139
Added:
( "a corrected slot survives a reconnect without adding volume",
140
Added:
`Quick,
141
Added:
fun () ->
142
Added:
let path, uri = temp_uri () in
143
Added:
Fun.protect
144
Added:
~finally:(fun () -> cleanup path)
145
Added:
(fun () ->
146
Added:
let repo = connect uri in
147
Added:
let s = S.make ~repo in
148
Added:
let t =
149
Added:
(ok (run (S.register s ~username:"alice" ~password:"heavyduty1")))
150
Added:
.Trainee.id
151
Added:
in
152
Added:
let _ =
153
Added:
ok (run (S.begin_workout s t ~routine:ideal ~now:(day 1) ()))
154
Added:
in
155
Added:
let _ = ok (run (S.log s t (single "laterals" 12. 8))) in
156
Added:
let record = Option.get (run (S.finish s t ~ended_at:(at 120))) in
157
Added:
let _ =
158
Added:
ok
159
Added:
(run
160
Added:
(S.replace_in_record s t record.Repository.id ~slot:1
161
Added:
(single "laterals" 15. 6)))
162
Added:
in
163
Added:
let repo = connect uri in
164
Added:
let s = S.make ~repo in
165
Added:
let reread =
166
Added:
Option.get (run (S.find_record s t record.Repository.id))
167
Added:
in
168
Added:
Alcotest.(check int)
169
Added:
"still one stimulus" 1
170
Added:
(List.length (Workout.stimuli reread.Repository.workout));
171
Added:
Alcotest.(check (float 0.001))
172
Added:
"corrected load persisted" 15.
173
Added:
(Stimulus.Effort.load
174
Added:
(List.hd
175
Added:
(Stimulus.efforts
176
Added:
(List.hd (Workout.stimuli reread.Repository.workout))))))
177
Added:
);
139
178
( "a short password persists and authenticates after a reconnect",
140
179
`Quick,
141
180
fun () ->