[OCaml] High Intensity Training Online
feat guide workout logging and completion feedback
Keep prescribed HD1 training records structured while allowing a session to end incomplete. Persist categorical context without interpreting it, retain end times through later corrections, and restrict warm-ups to the first prescribed stimulus.
Changed files
lib/app/memory_repo.ml
@@ -1,6 +1,5 @@
1
1
type t = {
2
2
routines : (Repository.routine_id * Prescription.Routine.t) list;
3
Removed:
mutable stored_log : Evidence.Log.t;
4
3
mutable stored : Repository.record list; (* most recent first *)
5
4
mutable next_id : int;
6
5
}
@@ -8,7 +7,6 @@
8
7
let create () =
9
8
{
10
9
routines = [ (Repository.routine_id "ideal", Prescription.Routine.ideal) ];
11
Removed:
stored_log = Evidence.Log.empty;
12
10
stored = [];
13
11
next_id = 1;
14
12
}
@@ -20,9 +18,28 @@
20
18
let id = Repository.workout_id (Printf.sprintf "w%d" t.next_id) in
21
19
let record = { Repository.id; workout } in
22
20
t.next_id <- t.next_id + 1;
23
Removed:
t.stored_log <- Evidence.Log.add t.stored_log workout;
24
21
t.stored <- record :: t.stored;
25
22
record
26
23
27
Removed:
let log t = t.stored_log
24
Added:
let equal_id (a : Repository.workout_id) (b : Repository.workout_id) =
25
Added:
String.equal (a :> string) (b :> string)
26
Added:
27
Added:
let find t id = List.find_opt (fun r -> equal_id r.Repository.id id) t.stored
28
Added:
29
Added:
let replace t record =
30
Added:
if Option.is_none (find t record.Repository.id) then false
31
Added:
else (
32
Added:
t.stored <-
33
Added:
List.map
34
Added:
(fun existing ->
35
Added:
if equal_id existing.Repository.id record.Repository.id then record
36
Added:
else existing)
37
Added:
t.stored;
38
Added:
true)
39
Added:
40
Added:
let log t =
41
Added:
List.fold_left
42
Added:
(fun log record -> Evidence.Log.add log record.Repository.workout)
43
Added:
Evidence.Log.empty (List.rev t.stored)
44
Added:
28
45
let history t = t.stored
lib/app/repository.ml
@@ -14,6 +14,8 @@
14
14
val list_routines : t -> (routine_id * Prescription.Routine.t) list
15
15
val find_routine : t -> routine_id -> Prescription.Routine.t option
16
16
val save : t -> Evidence.Workout.t -> record
17
Added:
val find : t -> workout_id -> record option
18
Added:
val replace : t -> record -> bool
17
19
val log : t -> Evidence.Log.t
18
20
val history : t -> record list
19
21
end
lib/app/repository.mli
@@ -20,8 +20,12 @@
20
20
val find_routine : t -> routine_id -> Prescription.Routine.t option
21
21
22
22
val save : t -> Evidence.Workout.t -> record
23
Removed:
(** Store the workout under an identity the adapter assigns. Callers do not
24
Removed:
invent identifiers. *)
23
Added:
(** Store the workout under an identity the adapter assigns. *)
24
Added:
25
Added:
val find : t -> workout_id -> record option
26
Added:
27
Added:
val replace : t -> record -> bool
28
Added:
(** Replace an existing record by identity. *)
25
29
26
30
val log : t -> Evidence.Log.t
27
31
(** The stored log — the only source of evidence. *)
lib/app/service.ml
@@ -1,7 +1,11 @@
1
1
module Make (R : Repository.S) = struct
2
Removed:
type t = { repo : R.t; mutable current : Evidence.Workout.t option }
2
Added:
type t = {
3
Added:
repo : R.t;
4
Added:
mutable active : Repository.routine_id option;
5
Added:
mutable current : Evidence.Workout.t option;
6
Added:
}
3
7
4
Removed:
let make ~repo = { repo; current = None }
8
Added:
let make ~repo = { repo; active = None; current = None }
5
9
let list_routines t = R.list_routines t.repo
6
10
7
11
type error = Unknown_routine | Not_recovered of Recovery.readiness
@@ -11,6 +15,19 @@
11
15
| Not_recovered readiness ->
12
16
Format.fprintf ppf "not recovered: %a" Recovery.pp_readiness readiness
13
17
18
Added:
let select_routine t id =
19
Added:
match R.find_routine t.repo id with
20
Added:
| None -> Error Unknown_routine
21
Added:
| Some _ ->
22
Added:
t.active <- Some id;
23
Added:
Ok ()
24
Added:
25
Added:
let active_routine t =
26
Added:
match t.active with
27
Added:
| None -> None
28
Added:
| Some id ->
29
Added:
Option.map (fun routine -> (id, routine)) (R.find_routine t.repo id)
30
Added:
14
31
let routine t id =
15
32
match R.find_routine t.repo id with
16
33
| Some r -> Ok r
@@ -85,16 +102,37 @@
85
102
match t.current with
86
103
| None -> None
87
104
| Some workout ->
88
Removed:
(* [current] only ever holds an unfinished workout — it is cleared the
89
Removed:
moment one is finished — so this cannot fail. *)
90
Removed:
let finished =
91
Removed:
Result.value
92
Removed:
(Evidence.Workout.finish workout ~ended_at)
93
Removed:
~default:workout
94
Removed:
in
105
Added:
let finished = Evidence.Workout.finish workout ~ended_at in
95
106
let record = R.save t.repo finished in
96
107
t.current <- None;
97
108
Some record
109
Added:
110
Added:
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
111
Added:
112
Added:
let find_record t id = R.find t.repo id
113
Added:
114
Added:
let replace t record =
115
Added:
if R.replace t.repo record then Ok record else Error Unknown_workout
116
Added:
117
Added:
let add_to_record t id stimulus =
118
Added:
match R.find t.repo id with
119
Added:
| None -> Error Unknown_workout
120
Added:
| Some record -> (
121
Added:
match
122
Added:
Evidence.Workout.add_stimulus record.Repository.workout stimulus
123
Added:
with
124
Added:
| Error error -> Error (Rejected_edit error)
125
Added:
| Ok workout -> replace t { record with Repository.workout })
126
Added:
127
Added:
let set_feedback t id feedback =
128
Added:
match R.find t.repo id with
129
Added:
| None -> Error Unknown_workout
130
Added:
| Some record -> (
131
Added:
match
132
Added:
Evidence.Workout.set_feedback record.Repository.workout feedback
133
Added:
with
134
Added:
| Error error -> Error (Rejected_edit error)
135
Added:
| Ok workout -> replace t { record with Repository.workout })
98
136
99
137
let history t = R.history t.repo
100
138
lib/app/service.mli
@@ -23,7 +23,11 @@
23
23
reading so a client can say how much longer. *)
24
24
25
25
val pp_error : Format.formatter -> error -> unit
26
Added:
val select_routine : t -> Repository.routine_id -> (unit, error) result
26
27
28
Added:
val active_routine :
29
Added:
t -> (Repository.routine_id * Prescription.Routine.t) option
30
Added:
27
31
val next_workout :
28
32
t -> routine:Repository.routine_id -> (Prescription.Workout.t, error) result
29
33
(** Where the cycle stands: the workout after the last one logged. *)
@@ -62,6 +66,22 @@
62
66
val finish : t -> ended_at:Recovery.timestamp -> Repository.record option
63
67
(** Complete and persist the workout in progress, clearing the slot. [None] if
64
68
nothing was in progress. *)
69
Added:
70
Added:
type edit_error = Unknown_workout | Rejected_edit of Evidence.Workout.error
71
Added:
72
Added:
val find_record : t -> Repository.workout_id -> Repository.record option
73
Added:
74
Added:
val add_to_record :
75
Added:
t ->
76
Added:
Repository.workout_id ->
77
Added:
Evidence.Stimulus.t ->
78
Added:
(Repository.record, edit_error) result
79
Added:
80
Added:
val set_feedback :
81
Added:
t ->
82
Added:
Repository.workout_id ->
83
Added:
Evidence.Workout.Feedback.t ->
84
Added:
(Repository.record, edit_error) result
65
85
66
86
val history : t -> Repository.record list
67
87
lib/core/evidence.ml
@@ -66,11 +66,16 @@
66
66
| Single of Movement.t
67
67
| Pair of { first : Movement.t; second : Movement.t }
68
68
69
Removed:
type t = { delivery : delivery; warm_ups : Warm_up.t list }
69
Added:
type t = {
70
Added:
delivery : delivery;
71
Added:
warm_ups : Warm_up.t list;
72
Added:
note : string option;
73
Added:
}
70
74
71
Removed:
let make ?(warm_ups = []) delivery = { delivery; warm_ups }
75
Added:
let make ?(warm_ups = []) ?note delivery = { delivery; warm_ups; note }
72
76
let delivery t = t.delivery
73
77
let warm_ups t = t.warm_ups
78
Added:
let note t = t.note
74
79
75
80
let movements t =
76
81
match t.delivery with
@@ -90,7 +95,63 @@
90
95
91
96
module Workout = struct
92
97
type shape = As_single | As_pair
98
Added:
type completeness = Complete | Incomplete
93
99
100
Added:
module Feedback = struct
101
Added:
type sleep = Sleep_poor | Sleep_ordinary | Sleep_good
102
Added:
type appetite = Appetite_reduced | Appetite_ordinary | Appetite_increased
103
Added:
104
Added:
type illness_stress =
105
Added:
| No_illness_or_stress
106
Added:
| Illness
107
Added:
| Stress
108
Added:
| Illness_and_stress
109
Added:
110
Added:
type motivation = Motivation_low | Motivation_ordinary | Motivation_high
111
Added:
type recovery = Recovery_poor | Recovery_ordinary | Recovery_good
112
Added:
113
Added:
type difficulty =
114
Added:
| Difficulty_easier
115
Added:
| Difficulty_expected
116
Added:
| Difficulty_harder
117
Added:
118
Added:
type t = {
119
Added:
sleep : sleep;
120
Added:
appetite : appetite;
121
Added:
illness_stress : illness_stress;
122
Added:
pain_injury : bool;
123
Added:
pain_detail : string option;
124
Added:
motivation : motivation;
125
Added:
recovery : recovery;
126
Added:
difficulty : difficulty;
127
Added:
note : string option;
128
Added:
}
129
Added:
130
Added:
let make ~sleep ~appetite ~illness_stress ~pain_injury ?pain_detail
131
Added:
~motivation ~recovery ~difficulty ?note () =
132
Added:
{
133
Added:
sleep;
134
Added:
appetite;
135
Added:
illness_stress;
136
Added:
pain_injury;
137
Added:
pain_detail;
138
Added:
motivation;
139
Added:
recovery;
140
Added:
difficulty;
141
Added:
note;
142
Added:
}
143
Added:
144
Added:
let sleep t = t.sleep
145
Added:
let appetite t = t.appetite
146
Added:
let illness_stress t = t.illness_stress
147
Added:
let pain_injury t = t.pain_injury
148
Added:
let pain_detail t = t.pain_detail
149
Added:
let motivation t = t.motivation
150
Added:
let recovery t = t.recovery
151
Added:
let difficulty t = t.difficulty
152
Added:
let note t = t.note
153
Added:
end
154
Added:
94
155
type error =
95
156
| Not_prescribed of Exercise.id
96
157
| Delivery_mismatch of {
@@ -98,15 +159,15 @@
98
159
prescribed : shape;
99
160
logged : shape;
100
161
}
101
Removed:
| Already_finished
162
Added:
| Warm_ups_after_first_stimulus
163
Added:
| Not_finished
102
164
103
165
type t = {
104
166
prescription : Prescription.Workout.t;
105
167
clearance : Recovery.clearance;
106
168
started_at : Recovery.timestamp;
107
169
ended_at : Recovery.timestamp option;
108
Removed:
(* Each performed stimulus with the index of the prescribed slot it answers,
109
Removed:
so that unanswered slots stay visible. *)
170
Added:
feedback : Feedback.t option;
110
171
performed : (int * Stimulus.t) list;
111
172
}
112
173
@@ -122,16 +183,27 @@
122
183
Format.fprintf ppf "%s is prescribed as %a but was logged as %a"
123
184
(exercise :> string)
124
185
pp_shape prescribed pp_shape logged
125
Removed:
| Already_finished -> Format.pp_print_string ppf "this workout is finished"
186
Added:
| Warm_ups_after_first_stimulus ->
187
Added:
Format.pp_print_string ppf
188
Added:
"warm-ups belong only before the first stimulus"
189
Added:
| Not_finished -> Format.pp_print_string ppf "this workout is not finished"
126
190
127
191
let start prescription ~clearance ~started_at =
128
Removed:
{ prescription; clearance; started_at; ended_at = None; performed = [] }
192
Added:
{
193
Added:
prescription;
194
Added:
clearance;
195
Added:
started_at;
196
Added:
ended_at = None;
197
Added:
feedback = None;
198
Added:
performed = [];
199
Added:
}
129
200
130
201
let prescription t = t.prescription
131
202
let clearance t = t.clearance
132
203
let started_at t = t.started_at
133
204
let ended_at t = t.ended_at
134
205
let is_finished t = Option.is_some t.ended_at
206
Added:
let feedback t = t.feedback
135
207
let stimuli t = List.map snd (List.rev t.performed)
136
208
137
209
let duration t =
@@ -149,24 +221,17 @@
149
221
| Stimulus.Single _ -> As_single
150
222
| Stimulus.Pair _ -> As_pair
151
223
152
Removed:
(* A logged movement answers a prescribed one when it is that movement, or a
153
Removed:
substitute the prescription allows *for that movement*. *)
154
224
let fills ~prescribed ~logged p =
155
225
Exercise.equal prescribed logged
156
226
|| List.exists (Exercise.equal logged)
157
227
(Prescription.Stimulus.allowed_substitutes p)
158
228
&& Exercise.may_substitute ~original:prescribed ~candidate:logged
159
229
160
Removed:
(* Whether the prescription mentions every movement logged, ignoring how they
161
Removed:
were delivered. This is what makes a shape complaint possible: the movements
162
Removed:
belong to this slot, but the delivery does not match it. *)
163
230
let mentions p s =
164
231
List.for_all
165
232
(fun e -> Prescription.Stimulus.permits p e)
166
233
(Stimulus.exercises s)
167
234
168
Removed:
(* Whether the stimulus answers the prescription exactly: same number of
169
Removed:
movements, each filling the prescribed role in order. *)
170
235
let conforms p s =
171
236
let logged = Stimulus.exercises s in
172
237
let prescribed = Prescription.Stimulus.exercises p in
@@ -184,13 +249,14 @@
184
249
indexed t |> List.filter (fun (i, _) -> not (List.mem i (answered t)))
185
250
186
251
let unperformed t = List.map snd (outstanding t)
252
Added:
let completeness t = if outstanding t = [] then Complete else Incomplete
187
253
188
254
let add_stimulus t s =
189
Removed:
if is_finished t then Error Already_finished
255
Added:
if t.performed <> [] && Stimulus.warm_ups s <> [] then
256
Added:
Error Warm_ups_after_first_stimulus
190
257
else
191
258
let candidates = List.filter (fun (_, p) -> mentions p s) (indexed t) in
192
259
let matching = List.filter (fun (_, p) -> conforms p s) candidates in
193
Removed:
(* A stimulus always has at least one movement. *)
194
260
let leading = Exercise.id (List.hd (Stimulus.exercises s)) in
195
261
match (candidates, matching) with
196
262
| [], _ -> Error (Not_prescribed leading)
@@ -203,8 +269,6 @@
203
269
logged = logged_shape s;
204
270
})
205
271
| _, matching ->
206
Removed:
(* Prefer an unanswered slot, so repeated work is visible as extra
207
Removed:
volume rather than silently overwriting a slot. *)
208
272
let unanswered =
209
273
List.filter (fun (i, _) -> not (List.mem i (answered t))) matching
210
274
in
@@ -213,11 +277,19 @@
213
277
| chosen :: _ -> chosen
214
278
| [] -> List.hd matching
215
279
in
216
Removed:
Ok { t with performed = (i, s) :: t.performed }
280
Added:
if Stimulus.warm_ups s <> [] && i <> 0 then
281
Added:
Error Warm_ups_after_first_stimulus
282
Added:
else Ok { t with performed = (i, s) :: t.performed }
217
283
218
284
let finish t ~ended_at =
219
Removed:
if is_finished t then Error Already_finished
220
Removed:
else Ok { t with ended_at = Some ended_at }
285
Added:
match t.ended_at with
286
Added:
| None -> { t with ended_at = Some ended_at }
287
Added:
| Some _ -> t
288
Added:
289
Added:
let set_feedback t feedback =
290
Added:
match t.ended_at with
291
Added:
| None -> Error Not_finished
292
Added:
| Some _ -> Ok { t with feedback = Some feedback }
221
293
222
294
let pp ppf t =
223
295
Format.fprintf ppf "%a (%d of %d)" Prescription.Workout.pp t.prescription
lib/core/evidence.mli
@@ -49,7 +49,7 @@
49
49
50
50
type t
51
51
52
Removed:
val make : ?warm_ups:Warm_up.t list -> delivery -> t
52
Added:
val make : ?warm_ups:Warm_up.t list -> ?note:string -> delivery -> t
53
53
(** Records the delivery as performed. *)
54
54
55
55
val delivery : t -> delivery
@@ -58,6 +58,7 @@
58
58
(** Performance order. *)
59
59
60
60
val warm_ups : t -> Warm_up.t list
61
Added:
val note : t -> string option
61
62
val exercises : t -> Exercise.t list
62
63
val extensions : t -> extension list
63
64
val is_extended : t -> bool
@@ -68,7 +69,52 @@
68
69
module Workout : sig
69
70
type t
70
71
type shape = As_single | As_pair
72
Added:
type completeness = Complete | Incomplete
71
73
74
Added:
module Feedback : sig
75
Added:
type sleep = Sleep_poor | Sleep_ordinary | Sleep_good
76
Added:
type appetite = Appetite_reduced | Appetite_ordinary | Appetite_increased
77
Added:
78
Added:
type illness_stress =
79
Added:
| No_illness_or_stress
80
Added:
| Illness
81
Added:
| Stress
82
Added:
| Illness_and_stress
83
Added:
84
Added:
type motivation = Motivation_low | Motivation_ordinary | Motivation_high
85
Added:
type recovery = Recovery_poor | Recovery_ordinary | Recovery_good
86
Added:
87
Added:
type difficulty =
88
Added:
| Difficulty_easier
89
Added:
| Difficulty_expected
90
Added:
| Difficulty_harder
91
Added:
92
Added:
type t
93
Added:
94
Added:
val make :
95
Added:
sleep:sleep ->
96
Added:
appetite:appetite ->
97
Added:
illness_stress:illness_stress ->
98
Added:
pain_injury:bool ->
99
Added:
?pain_detail:string ->
100
Added:
motivation:motivation ->
101
Added:
recovery:recovery ->
102
Added:
difficulty:difficulty ->
103
Added:
?note:string ->
104
Added:
unit ->
105
Added:
t
106
Added:
107
Added:
val sleep : t -> sleep
108
Added:
val appetite : t -> appetite
109
Added:
val illness_stress : t -> illness_stress
110
Added:
val pain_injury : t -> bool
111
Added:
val pain_detail : t -> string option
112
Added:
val motivation : t -> motivation
113
Added:
val recovery : t -> recovery
114
Added:
val difficulty : t -> difficulty
115
Added:
val note : t -> string option
116
Added:
end
117
Added:
72
118
type error =
73
119
| Not_prescribed of Exercise.id
74
120
| Delivery_mismatch of {
@@ -76,7 +122,8 @@
76
122
prescribed : shape;
77
123
logged : shape;
78
124
}
79
Removed:
| Already_finished
125
Added:
| Warm_ups_after_first_stimulus
126
Added:
| Not_finished
80
127
81
128
val pp_error : Format.formatter -> error -> unit
82
129
@@ -85,25 +132,29 @@
85
132
clearance:Recovery.clearance ->
86
133
started_at:Recovery.timestamp ->
87
134
t
88
Removed:
(** Clearance records the basis for starting. *)
89
135
90
136
val add_stimulus : t -> Stimulus.t -> (t, error) result
91
Removed:
(** Only prescribed movements and delivery shapes are accepted. *)
137
Added:
(** Warm-ups are allowed only on the first recorded stimulus. *)
92
138
93
Removed:
val finish : t -> ended_at:Recovery.timestamp -> (t, error) result
139
Added:
val finish : t -> ended_at:Recovery.timestamp -> t
140
Added:
(** Sets [ended_at] once; later calls retain the first value. *)
141
Added:
142
Added:
val set_feedback : t -> Feedback.t -> (t, error) result
143
Added:
(** Requires a finished workout. *)
144
Added:
94
145
val prescription : t -> Prescription.Workout.t
95
146
val clearance : t -> Recovery.clearance
96
147
val started_at : t -> Recovery.timestamp
97
148
val ended_at : t -> Recovery.timestamp option
98
149
val is_finished : t -> bool
99
150
val duration : t -> Recovery.duration option
151
Added:
val completeness : t -> completeness
152
Added:
val feedback : t -> Feedback.t option
100
153
101
154
val stimuli : t -> Stimulus.t list
102
155
(** Performance order. *)
103
156
104
157
val outstanding : t -> (int * Prescription.Stimulus.t) list
105
Removed:
(** Unanswered prescribed slots and their positions. *)
106
Removed:
107
158
val unperformed : t -> Prescription.Stimulus.t list
108
159
val pp : Format.formatter -> t -> unit
109
160
end
lib/web/pages.ml
@@ -44,7 +44,8 @@
44
44
h1 [ txt "hito" ];
45
45
nav
46
46
[
47
Removed:
a ~service:Routes.home [ txt "Routines" ] ();
47
Added:
a ~service:Routes.home [ txt "Home" ] ();
48
Added:
a ~service:Routes.routine [ txt "Routine" ] ();
48
49
a ~service:Routes.log [ txt "Current workout" ] ();
49
50
a ~service:Routes.history [ txt "History" ] ();
50
51
];
@@ -85,8 +86,8 @@
85
86
div
86
87
(List.map
87
88
(fun (id, r) ->
88
Removed:
Form.post_form ~service:Routes.begin_workout
89
Removed:
(fun (routine, reason) ->
89
Added:
Form.post_form ~service:Routes.select_routine
90
Added:
(fun routine ->
90
91
[
91
92
fieldset
92
93
~legend:(legend [ txt (Prescription.Routine.name r) ])
@@ -99,16 +100,67 @@
99
100
];
100
101
Form.input ~input_type:`Hidden ~name:routine
101
102
~value:(id_string id) Form.string;
102
Removed:
Form.input ~input_type:`Hidden ~name:reason ~value:""
103
Added:
Form.input ~input_type:`Submit ~value:"Use this routine"
103
104
Form.string;
104
Removed:
Form.input ~input_type:`Submit
105
Removed:
~value:"Begin next workout" Form.string;
106
105
];
107
106
])
108
107
())
109
108
routines);
109
Added:
fieldset
110
Added:
~legend:(legend [ txt "Create routine" ])
111
Added:
[
112
Added:
p [ txt "Custom routine authoring is coming soon." ];
113
Added:
Form.input
114
Added:
~a:[ a_disabled () ]
115
Added:
~input_type:`Submit ~value:"Create routine — coming soon"
116
Added:
Form.string;
117
Added:
];
110
118
]
111
119
120
Added:
let home ~routine ~routine_name ~next ~readiness =
121
Added:
let status =
122
Added:
match readiness with
123
Added:
| Recovery.Ready -> "Recovery is complete."
124
Added:
| Recovery.Recovering { rested; recommended } ->
125
Added:
Format.asprintf "Recovery: %a of %a." Recovery.pp_duration rested
126
Added:
Recovery.pp_duration recommended
127
Added:
in
128
Added:
shell ~title:"Home"
129
Added:
[
130
Added:
h2 [ txt routine_name ];
131
Added:
p [ txt ("Next: " ^ Prescription.Workout.name next) ];
132
Added:
p [ txt status ];
133
Added:
Form.post_form ~service:Routes.begin_workout
134
Added:
(fun (routine_name, reason) ->
135
Added:
[
136
Added:
Form.input ~input_type:`Hidden ~name:routine_name
137
Added:
~value:(id_string routine) Form.string;
138
Added:
Form.input ~input_type:`Hidden ~name:reason ~value:"" Form.string;
139
Added:
Form.input ~input_type:`Submit ~value:"Begin next workout"
140
Added:
Form.string;
141
Added:
])
142
Added:
();
143
Added:
]
144
Added:
145
Added:
let routine routine =
146
Added:
shell ~title:"Routine"
147
Added:
[
148
Added:
h2 [ txt (Prescription.Routine.name routine) ];
149
Added:
ul
150
Added:
(List.map
151
Added:
(fun workout ->
152
Added:
li
153
Added:
[
154
Added:
txt (Prescription.Workout.name workout);
155
Added:
ul
156
Added:
(List.map
157
Added:
(fun stimulus ->
158
Added:
li [ txt (describe_prescription stimulus) ])
159
Added:
(Prescription.Workout.stimuli workout));
160
Added:
])
161
Added:
(Prescription.Routine.workouts routine));
162
Added:
]
163
Added:
112
164
let recovery_gate ~(routine : Repository.routine_id) ~workout ~readiness =
113
165
let remaining =
114
166
match readiness with
@@ -159,90 +211,127 @@
159
211
();
160
212
]
161
213
162
Removed:
let single_form ~slot ~prescription =
214
Added:
let warm_up_fields ~allow ~exercise ~warm_ups_name =
215
Added:
if not allow then []
216
Added:
else
217
Added:
[
218
Added:
label [ txt "Warm-ups (optional: one load,reps pair per line)" ];
219
Added:
Form.input
220
Added:
~a:[ a_placeholder "40,10\n60,6" ]
221
Added:
~input_type:`Text ~name:warm_ups_name Form.string;
222
Added:
p
223
Added:
~a:[ a_class [ "done" ] ]
224
Added:
[ txt ("All warm-ups use " ^ Exercise.name exercise ^ ".") ];
225
Added:
]
226
Added:
227
Added:
let single_form ~workout_id ~allow_warm_ups ~slot ~prescription =
163
228
Form.post_form ~service:Routes.log_single
164
Removed:
(fun (slot_name, (load_name, (reps_name, ext_name))) ->
229
Added:
(fun ( workout_name,
230
Added:
( slot_name,
231
Added:
(load_name, (reps_name, (ext_name, (note_name, warm_ups_name)))) )
232
Added:
) ->
165
233
[
166
234
fieldset
167
235
~legend:(legend [ txt (describe_prescription prescription) ])
168
Removed:
[
169
Removed:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
170
Removed:
div
171
Removed:
~a:[ a_class [ "row" ] ]
172
Removed:
[
173
Removed:
div
174
Removed:
[
175
Removed:
label ~a:[ a_label_for "l" ] [ txt "Load (kg)" ];
176
Removed:
Form.input
177
Removed:
~a:[ a_id "l"; a_step (Some 0.5); a_required () ]
178
Removed:
~input_type:`Number ~name:load_name Form.float;
179
Removed:
];
180
Removed:
div
181
Removed:
[
182
Removed:
label ~a:[ a_label_for "r" ] [ txt "Reps to failure" ];
183
Removed:
Form.input
184
Removed:
~a:[ a_id "r"; a_required () ]
185
Removed:
~input_type:`Number ~name:reps_name Form.int;
186
Removed:
];
187
Removed:
];
188
Removed:
label [ txt "Ending" ];
189
Removed:
extension_select ext_name;
190
Removed:
Form.input ~input_type:`Submit ~value:"Record" Form.string;
191
Removed:
];
236
Added:
([
237
Added:
Form.input ~input_type:`Hidden ~name:workout_name ~value:workout_id
238
Added:
Form.string;
239
Added:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
240
Added:
div
241
Added:
~a:[ a_class [ "row" ] ]
242
Added:
[
243
Added:
div
244
Added:
[
245
Added:
label [ txt "Load (kg)" ];
246
Added:
Form.input
247
Added:
~a:[ a_step (Some 0.5); a_required () ]
248
Added:
~input_type:`Number ~name:load_name Form.float;
249
Added:
];
250
Added:
div
251
Added:
[
252
Added:
label [ txt "Reps to failure" ];
253
Added:
Form.input
254
Added:
~a:[ a_required () ]
255
Added:
~input_type:`Number ~name:reps_name Form.int;
256
Added:
];
257
Added:
];
258
Added:
label [ txt "Ending" ];
259
Added:
extension_select ext_name;
260
Added:
label [ txt "Note (optional)" ];
261
Added:
Form.input ~input_type:`Text ~name:note_name Form.string;
262
Added:
]
263
Added:
@ warm_up_fields ~allow:allow_warm_ups
264
Added:
~exercise:
265
Added:
(match Prescription.Stimulus.delivery prescription with
266
Added:
| Prescription.Stimulus.Single e -> e
267
Added:
| Prescription.Stimulus.Pre_exhaust _ -> assert false)
268
Added:
~warm_ups_name
269
Added:
@ [ Form.input ~input_type:`Submit ~value:"Record" Form.string ]);
192
270
])
193
271
()
194
272
195
Removed:
let pair_form ~slot ~prescription ~isolation ~compound =
273
Added:
let pair_form ~workout_id ~allow_warm_ups ~slot ~prescription ~isolation
274
Added:
~compound =
196
275
Form.post_form ~service:Routes.log_pair
197
Removed:
(fun (slot_name, (iso_load, (iso_reps, (comp_load, (comp_reps, ext_name)))))
198
Removed:
->
276
Added:
(fun ( workout_name,
277
Added:
( slot_name,
278
Added:
( iso_load,
279
Added:
( iso_reps,
280
Added:
(comp_load, (comp_reps, (ext_name, (note_name, warm_ups_name))))
281
Added:
) ) ) ) ->
199
282
[
200
283
fieldset
201
284
~legend:(legend [ txt (describe_prescription prescription) ])
202
Removed:
[
203
Removed:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
204
Removed:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name isolation) ];
205
Removed:
div
206
Removed:
~a:[ a_class [ "row" ] ]
207
Removed:
[
208
Removed:
div
209
Removed:
[
210
Removed:
label [ txt "Load (kg)" ];
211
Removed:
Form.input
212
Removed:
~a:[ a_step (Some 0.5); a_required () ]
213
Removed:
~input_type:`Number ~name:iso_load Form.float;
214
Removed:
];
215
Removed:
div
216
Removed:
[
217
Removed:
label [ txt "Reps" ];
218
Removed:
Form.input
219
Removed:
~a:[ a_required () ]
220
Removed:
~input_type:`Number ~name:iso_reps Form.int;
221
Removed:
];
222
Removed:
];
223
Removed:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name compound) ];
224
Removed:
div
225
Removed:
~a:[ a_class [ "row" ] ]
226
Removed:
[
227
Removed:
div
228
Removed:
[
229
Removed:
label [ txt "Load (kg)" ];
230
Removed:
Form.input
231
Removed:
~a:[ a_step (Some 0.5); a_required () ]
232
Removed:
~input_type:`Number ~name:comp_load Form.float;
233
Removed:
];
234
Removed:
div
235
Removed:
[
236
Removed:
label [ txt "Reps" ];
237
Removed:
Form.input
238
Removed:
~a:[ a_required () ]
239
Removed:
~input_type:`Number ~name:comp_reps Form.int;
240
Removed:
];
241
Removed:
];
242
Removed:
label [ txt "Ending" ];
243
Removed:
extension_select ext_name;
244
Removed:
Form.input ~input_type:`Submit ~value:"Record" Form.string;
245
Removed:
];
285
Added:
([
286
Added:
Form.input ~input_type:`Hidden ~name:workout_name ~value:workout_id
287
Added:
Form.string;
288
Added:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
289
Added:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name isolation) ];
290
Added:
div
291
Added:
~a:[ a_class [ "row" ] ]
292
Added:
[
293
Added:
div
294
Added:
[
295
Added:
label [ txt "Load (kg)" ];
296
Added:
Form.input
297
Added:
~a:[ a_step (Some 0.5); a_required () ]
298
Added:
~input_type:`Number ~name:iso_load Form.float;
299
Added:
];
300
Added:
div
301
Added:
[
302
Added:
label [ txt "Reps" ];
303
Added:
Form.input
304
Added:
~a:[ a_required () ]
305
Added:
~input_type:`Number ~name:iso_reps Form.int;
306
Added:
];
307
Added:
];
308
Added:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name compound) ];
309
Added:
div
310
Added:
~a:[ a_class [ "row" ] ]
311
Added:
[
312
Added:
div
313
Added:
[
314
Added:
label [ txt "Load (kg)" ];
315
Added:
Form.input
316
Added:
~a:[ a_step (Some 0.5); a_required () ]
317
Added:
~input_type:`Number ~name:comp_load Form.float;
318
Added:
];
319
Added:
div
320
Added:
[
321
Added:
label [ txt "Reps" ];
322
Added:
Form.input
323
Added:
~a:[ a_required () ]
324
Added:
~input_type:`Number ~name:comp_reps Form.int;
325
Added:
];
326
Added:
];
327
Added:
label [ txt "Ending" ];
328
Added:
extension_select ext_name;
329
Added:
label [ txt "Note (optional)" ];
330
Added:
Form.input ~input_type:`Text ~name:note_name Form.string;
331
Added:
]
332
Added:
@ warm_up_fields ~allow:allow_warm_ups ~exercise:isolation
333
Added:
~warm_ups_name
334
Added:
@ [ Form.input ~input_type:`Submit ~value:"Record" Form.string ]);
246
335
])
247
336
()
248
337
@@ -265,8 +354,9 @@
265
354
^ String.concat " then "
266
355
(List.map (Format.asprintf "%a" Evidence.Stimulus.pp_extension) es)
267
356
268
Removed:
let log_workout ~workout =
357
Added:
let log_workout ~record_id ~workout =
269
358
let prescription = Evidence.Workout.prescription workout in
359
Added:
let workout_id = Option.value ~default:"" record_id in
270
360
let performed = Evidence.Workout.stimuli workout in
271
361
let outstanding = Evidence.Workout.outstanding workout in
272
362
let override_note =
@@ -303,20 +393,28 @@
303
393
h2 [ txt "Still to do" ]
304
394
:: List.map
305
395
(fun (slot, p) ->
396
Added:
let allow_warm_ups = slot = 0 && performed = [] in
306
397
match Prescription.Stimulus.delivery p with
307
398
| Prescription.Stimulus.Single _ ->
308
Removed:
single_form ~slot ~prescription:p
399
Added:
single_form ~workout_id ~allow_warm_ups ~slot
400
Added:
~prescription:p
309
401
| Prescription.Stimulus.Pre_exhaust { isolation; compound } ->
310
Removed:
pair_form ~slot ~prescription:p ~isolation ~compound)
402
Added:
pair_form ~workout_id ~allow_warm_ups ~slot ~prescription:p
403
Added:
~isolation ~compound)
311
404
outstanding)
312
Removed:
@ [
313
Removed:
Form.post_form ~service:Routes.finish
314
Removed:
(fun () ->
315
Removed:
[
316
Removed:
Form.input ~input_type:`Submit ~value:"Finish workout" Form.string;
317
Removed:
])
318
Removed:
();
319
Removed:
])
405
Added:
@
406
Added:
match record_id with
407
Added:
| Some _ -> []
408
Added:
| None ->
409
Added:
[
410
Added:
Form.post_form ~service:Routes.finish
411
Added:
(fun () ->
412
Added:
[
413
Added:
Form.input ~input_type:`Submit ~value:"Finish workout"
414
Added:
Form.string;
415
Added:
])
416
Added:
();
417
Added:
])
320
418
321
419
let history ~records =
322
420
shell ~title:"History"
@@ -328,6 +426,26 @@
328
426
(List.map
329
427
(fun r ->
330
428
let w = r.Repository.workout in
429
Added:
let status =
430
Added:
let completeness =
431
Added:
match Evidence.Workout.completeness w with
432
Added:
| Evidence.Workout.Complete -> "complete"
433
Added:
| Incomplete -> "incomplete"
434
Added:
in
435
Added:
let ended =
436
Added:
match Evidence.Workout.ended_at w with
437
Added:
| None -> "not finished"
438
Added:
| Some time ->
439
Added:
Printf.sprintf "ended %d"
440
Added:
(Recovery.timestamp_to_unix_seconds time)
441
Added:
in
442
Added:
let feedback =
443
Added:
if Option.is_some (Evidence.Workout.feedback w) then
444
Added:
"; feedback saved"
445
Added:
else "; no feedback"
446
Added:
in
447
Added:
ended ^ "; " ^ completeness ^ feedback
448
Added:
in
331
449
li
332
450
[
333
451
txt
@@ -335,10 +453,86 @@
335
453
(Prescription.Workout.name
336
454
(Evidence.Workout.prescription w))
337
455
(List.length (Evidence.Workout.stimuli w)));
456
Added:
p ~a:[ a_class [ "done" ] ] [ txt status ];
457
Added:
a ~service:Routes.edit
458
Added:
[ txt "Edit missing records" ]
459
Added:
(r.Repository.id :> string);
338
460
ul
339
461
(List.map
340
462
(fun s -> li [ txt (describe_stimulus s) ])
341
463
(Evidence.Workout.stimuli w));
342
464
])
343
465
records));
466
Added:
]
467
Added:
468
Added:
let feedback ~record =
469
Added:
let option name values =
470
Added:
match
471
Added:
List.map
472
Added:
(fun (value, label) -> Form.Option ([], value, Some (txt label), false))
473
Added:
values
474
Added:
with
475
Added:
| first :: rest -> Form.select ~name Form.string first rest
476
Added:
| [] -> assert false
477
Added:
in
478
Added:
shell ~title:"Workout feedback"
479
Added:
[
480
Added:
h2 [ txt "Workout complete" ];
481
Added:
p
482
Added:
[
483
Added:
txt "Record any context; this feedback is not scored or interpreted.";
484
Added:
];
485
Added:
Form.post_form ~service:Routes.feedback
486
Added:
(fun (workout, rest) ->
487
Added:
let sleep, rest = rest in
488
Added:
let appetite, rest = rest in
489
Added:
let illness_stress, rest = rest in
490
Added:
let pain, rest = rest in
491
Added:
let pain_detail, rest = rest in
492
Added:
let motivation, rest = rest in
493
Added:
let recovery, rest = rest in
494
Added:
let difficulty, note = rest in
495
Added:
[
496
Added:
Form.input ~input_type:`Hidden ~name:workout
497
Added:
~value:(record.Repository.id :> string)
498
Added:
Form.string;
499
Added:
label [ txt "Sleep" ];
500
Added:
option sleep
501
Added:
[ ("poor", "poor"); ("ordinary", "ordinary"); ("good", "good") ];
502
Added:
label [ txt "Appetite" ];
503
Added:
option appetite
504
Added:
[
505
Added:
("reduced", "reduced");
506
Added:
("ordinary", "ordinary");
507
Added:
("increased", "increased");
508
Added:
];
509
Added:
label [ txt "Illness or stress" ];
510
Added:
option illness_stress
511
Added:
[
512
Added:
("none", "none");
513
Added:
("illness", "illness");
514
Added:
("stress", "stress");
515
Added:
("both", "both");
516
Added:
];
517
Added:
label [ txt "Pain or injury" ];
518
Added:
Form.input ~input_type:`Checkbox ~name:pain Form.bool;
519
Added:
Form.input ~input_type:`Text ~name:pain_detail Form.string;
520
Added:
label [ txt "Motivation" ];
521
Added:
option motivation
522
Added:
[ ("low", "low"); ("ordinary", "ordinary"); ("high", "high") ];
523
Added:
label [ txt "Perceived recovery" ];
524
Added:
option recovery
525
Added:
[ ("poor", "poor"); ("ordinary", "ordinary"); ("good", "good") ];
526
Added:
label [ txt "Exercise difficulty" ];
527
Added:
option difficulty
528
Added:
[
529
Added:
("easier", "easier");
530
Added:
("expected", "expected");
531
Added:
("harder", "harder");
532
Added:
];
533
Added:
label [ txt "Overall note" ];
534
Added:
Form.input ~input_type:`Text ~name:note Form.string;
535
Added:
Form.input ~input_type:`Submit ~value:"Save feedback" Form.string;
536
Added:
])
537
Added:
();
344
538
]
lib/web/pages.mli
@@ -1,6 +1,4 @@
1
Removed:
(** Page rendering. Pure view functions: they read what they are given and
2
Removed:
return HTML, and do nothing else. All domain access happens in {!Services}.
3
Removed:
*)
1
Added:
(** Pure server-rendered pages. *)
4
2
5
3
open Hito_app
6
4
@@ -9,21 +7,22 @@
9
7
val choose_routine :
10
8
routines:(Repository.routine_id * Prescription.Routine.t) list -> page
11
9
10
Added:
val home :
11
Added:
routine:Repository.routine_id ->
12
Added:
routine_name:string ->
13
Added:
next:Prescription.Workout.t ->
14
Added:
readiness:Recovery.readiness ->
15
Added:
page
16
Added:
17
Added:
val routine : Prescription.Routine.t -> page
18
Added:
12
19
val recovery_gate :
13
20
routine:Repository.routine_id ->
14
21
workout:Prescription.Workout.t ->
15
22
readiness:Recovery.readiness ->
16
23
page
17
Removed:
(** The refusal. States how much of the recommended rest remains, and offers to
18
Removed:
start anyway only once a reason has been given — HD1 treats training before
19
Removed:
recovery as the primary error, so it is deliberately a second step rather
20
Removed:
than one click. *)
21
24
22
Removed:
val log_workout : workout:Evidence.Workout.t -> page
23
Removed:
(** The workout in progress: what is outstanding, what has been performed, and a
24
Removed:
form per outstanding stimulus. *)
25
Removed:
25
Added:
val log_workout : record_id:string option -> workout:Evidence.Workout.t -> page
26
Added:
val feedback : record:Repository.record -> page
26
27
val history : records:Repository.record list -> page
27
Removed:
28
28
val problem : title:string -> detail:string -> page
29
Removed:
(** Something the request asked for could not be done. *)
lib/web/routes.ml
@@ -60,7 +60,8 @@
60
60
(Eliom_service.Post
61
61
( Eliom_parameter.unit,
62
62
Eliom_parameter.(
63
Removed:
int "slot" ** float "load" ** int "reps" ** string "extension") ))
63
Added:
string "workout" ** int "slot" ** float "load" ** int "reps"
64
Added:
** string "extension" ** string "note" ** string "warm_ups") ))
64
65
()
65
66
66
67
(* POST /log-pair — an isolation carried into a compound, no pause between. *)
@@ -70,12 +71,45 @@
70
71
(Eliom_service.Post
71
72
( Eliom_parameter.unit,
72
73
Eliom_parameter.(
73
Removed:
int "slot" ** float "iso_load" ** int "iso_reps"
74
Removed:
** float "comp_load" ** int "comp_reps" ** string "extension") ))
74
Added:
string "workout" ** int "slot" ** float "iso_load"
75
Added:
** int "iso_reps" ** float "comp_load" ** int "comp_reps"
76
Added:
** string "extension" ** string "note" ** string "warm_ups") ))
75
77
()
76
78
77
79
(* POST /finish — complete and persist. *)
78
80
let finish =
79
81
Eliom_service.create ~path:(Eliom_service.Path [ "finish" ])
80
82
~meth:(Eliom_service.Post (Eliom_parameter.unit, Eliom_parameter.unit))
83
Added:
()
84
Added:
85
Added:
(* GET /routine — active routine details. *)
86
Added:
let routine =
87
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "routine" ])
88
Added:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
89
Added:
90
Added:
(* POST /select-routine — make a routine active without beginning it. *)
91
Added:
let select_routine =
92
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "select-routine" ])
93
Added:
~meth:
94
Added:
(Eliom_service.Post
95
Added:
(Eliom_parameter.unit, Eliom_parameter.(string "routine")))
96
Added:
()
97
Added:
98
Added:
(* POST /feedback — attach categorical feedback to a finished workout. *)
99
Added:
let feedback =
100
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "feedback" ])
101
Added:
~meth:
102
Added:
(Eliom_service.Post
103
Added:
( Eliom_parameter.unit,
104
Added:
Eliom_parameter.(
105
Added:
string "workout" ** string "sleep" ** string "appetite"
106
Added:
** string "illness_stress" ** bool "pain" ** string "pain_detail"
107
Added:
** string "motivation" ** string "recovery" ** string "difficulty"
108
Added:
** string "note") ))
109
Added:
()
110
Added:
111
Added:
(* GET /edit — add prescribed records to a saved workout without changing its end. *)
112
Added:
let edit =
113
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "edit" ])
114
Added:
~meth:(Eliom_service.Get Eliom_parameter.(string "workout"))
81
115
()
lib/web/services.ml
@@ -12,17 +12,47 @@
12
12
13
13
let home_page () =
14
14
match Service.in_progress service with
15
Removed:
| Some workout -> Pages.log_workout ~workout
16
Removed:
| None -> Pages.choose_routine ~routines:(Service.list_routines service)
15
Added:
| Some workout -> Pages.log_workout ~record_id:None ~workout
16
Added:
| None -> (
17
Added:
match Service.active_routine service with
18
Added:
| None -> Pages.choose_routine ~routines:(Service.list_routines service)
19
Added:
| Some (routine, selected) -> (
20
Added:
match
21
Added:
( Service.next_workout service ~routine,
22
Added:
Service.readiness service ~routine ~now:(now ()) )
23
Added:
with
24
Added:
| Ok next, Ok readiness ->
25
Added:
Pages.home ~routine
26
Added:
~routine_name:(Prescription.Routine.name selected)
27
Added:
~next ~readiness
28
Added:
| Error error, _ | _, Error error ->
29
Added:
Pages.problem ~title:"Routine unavailable"
30
Added:
~detail:(Format.asprintf "%a" Service.pp_error error)))
17
31
18
32
let register () =
19
33
Eliom_registration.Html.register ~service:Routes.home (fun () () ->
20
34
Lwt.return (home_page ()));
21
35
36
Added:
Eliom_registration.Html.register ~service:Routes.select_routine
37
Added:
(fun () routine ->
38
Added:
let routine = Repository.routine_id routine in
39
Added:
Lwt.return
40
Added:
(match Service.select_routine service routine with
41
Added:
| Ok () -> home_page ()
42
Added:
| Error error ->
43
Added:
Pages.problem ~title:"Unknown routine"
44
Added:
~detail:(Format.asprintf "%a" Service.pp_error error)));
45
Added:
46
Added:
Eliom_registration.Html.register ~service:Routes.routine (fun () () ->
47
Added:
Lwt.return
48
Added:
(match Service.active_routine service with
49
Added:
| None -> Pages.choose_routine ~routines:(Service.list_routines service)
50
Added:
| Some (_, routine) -> Pages.routine routine));
51
Added:
22
52
Eliom_registration.Html.register ~service:Routes.log (fun () () ->
23
53
Lwt.return
24
54
(match Service.in_progress service with
25
Removed:
| Some workout -> Pages.log_workout ~workout
55
Added:
| Some workout -> Pages.log_workout ~record_id:None ~workout
26
56
| None ->
27
57
Pages.problem ~title:"No workout in progress"
28
58
~detail:"Choose a routine to begin one."));
@@ -40,7 +70,7 @@
40
70
(match
41
71
Service.begin_workout service ~routine ~now:(now ()) ?override ()
42
72
with
43
Removed:
| Ok workout -> Pages.log_workout ~workout
73
Added:
| Ok workout -> Pages.log_workout ~record_id:None ~workout
44
74
| Error (Service.Not_recovered readiness) -> (
45
75
match Service.next_workout service ~routine with
46
76
| Ok workout -> Pages.recovery_gate ~routine ~workout ~readiness
@@ -51,18 +81,6 @@
51
81
Pages.problem ~title:"Unknown routine"
52
82
~detail:"That routine is not in the catalogue."));
53
83
54
Removed:
let logged result =
55
Removed:
Lwt.return
56
Removed:
(match result with
57
Removed:
| Ok workout -> Pages.log_workout ~workout
58
Removed:
| Error Service.No_workout_in_progress ->
59
Removed:
Pages.problem ~title:"No workout in progress"
60
Removed:
~detail:"Choose a routine to begin one."
61
Removed:
| Error (Service.Rejected e) ->
62
Removed:
Pages.problem ~title:"That is not what was prescribed"
63
Removed:
~detail:(Format.asprintf "%a" Evidence.Workout.pp_error e))
64
Removed:
in
65
Removed:
66
84
let build_movement ~exercise ~load ~reps ~extension =
67
85
match (Units.Weight.of_kg load, Units.Reps.of_int reps) with
68
86
| Ok load, Ok reps ->
@@ -75,18 +93,150 @@
75
93
| Error e, _ | _, Error e -> Error (Format.asprintf "%a" Units.pp_error e)
76
94
in
77
95
96
Added:
let optional_text text =
97
Added:
let text = String.trim text in
98
Added:
if text = "" then None else Some text
99
Added:
in
100
Added:
101
Added:
let feedback_of_strings ~sleep:sleep_text ~appetite:appetite_text
102
Added:
~illness_stress:illness_stress_text ~pain ~pain_detail:pain_detail_text
103
Added:
~motivation:motivation_text ~recovery:recovery_text
104
Added:
~difficulty:difficulty_text ~note:note_text =
105
Added:
let open Evidence.Workout.Feedback in
106
Added:
let sleep =
107
Added:
match sleep_text with
108
Added:
| "poor" -> Some Sleep_poor
109
Added:
| "ordinary" -> Some Sleep_ordinary
110
Added:
| "good" -> Some Sleep_good
111
Added:
| _ -> None
112
Added:
in
113
Added:
let appetite =
114
Added:
match appetite_text with
115
Added:
| "reduced" -> Some Appetite_reduced
116
Added:
| "ordinary" -> Some Appetite_ordinary
117
Added:
| "increased" -> Some Appetite_increased
118
Added:
| _ -> None
119
Added:
in
120
Added:
let illness_stress =
121
Added:
match illness_stress_text with
122
Added:
| "none" -> Some No_illness_or_stress
123
Added:
| "illness" -> Some Illness
124
Added:
| "stress" -> Some Stress
125
Added:
| "both" -> Some Illness_and_stress
126
Added:
| _ -> None
127
Added:
in
128
Added:
let motivation =
129
Added:
match motivation_text with
130
Added:
| "low" -> Some Motivation_low
131
Added:
| "ordinary" -> Some Motivation_ordinary
132
Added:
| "high" -> Some Motivation_high
133
Added:
| _ -> None
134
Added:
in
135
Added:
let recovery =
136
Added:
match recovery_text with
137
Added:
| "poor" -> Some Recovery_poor
138
Added:
| "ordinary" -> Some Recovery_ordinary
139
Added:
| "good" -> Some Recovery_good
140
Added:
| _ -> None
141
Added:
in
142
Added:
let difficulty =
143
Added:
match difficulty_text with
144
Added:
| "easier" -> Some Difficulty_easier
145
Added:
| "expected" -> Some Difficulty_expected
146
Added:
| "harder" -> Some Difficulty_harder
147
Added:
| _ -> None
148
Added:
in
149
Added:
match
150
Added:
(sleep, appetite, illness_stress, motivation, recovery, difficulty)
151
Added:
with
152
Added:
| ( Some sleep,
153
Added:
Some appetite,
154
Added:
Some illness_stress,
155
Added:
Some motivation,
156
Added:
Some recovery,
157
Added:
Some difficulty ) ->
158
Added:
Some
159
Added:
(make ~sleep ~appetite ~illness_stress ~pain_injury:pain
160
Added:
?pain_detail:(optional_text pain_detail_text)
161
Added:
~motivation ~recovery ~difficulty ?note:(optional_text note_text)
162
Added:
())
163
Added:
| _ -> None
164
Added:
in
165
Added:
78
166
(* The slot names which prescribed stimulus is being answered. *)
79
Removed:
let prescribed_at slot =
80
Removed:
match Service.in_progress service with
167
Added:
let target_workout workout_id =
168
Added:
if workout_id = "" then
169
Added:
Option.map (fun workout -> (None, workout)) (Service.in_progress service)
170
Added:
else
171
Added:
Service.find_record service (Repository.workout_id workout_id)
172
Added:
|> Option.map (fun record ->
173
Added:
(Some record.Repository.id, record.Repository.workout))
174
Added:
in
175
Added:
let prescribed_at workout_id slot =
176
Added:
match target_workout workout_id with
81
177
| None -> None
82
Removed:
| Some workout ->
178
Added:
| Some (record_id, workout) ->
83
179
List.assoc_opt slot (Evidence.Workout.outstanding workout)
84
Removed:
|> Option.map (fun p -> (workout, p))
180
Added:
|> Option.map (fun p -> (record_id, p))
85
181
in
182
Added:
let warm_ups_of_text ~exercise text =
183
Added:
let warm_up line =
184
Added:
match String.split_on_char ',' (String.trim line) with
185
Added:
| [ load; reps ] -> (
186
Added:
try
187
Added:
let load = float_of_string (String.trim load) in
188
Added:
let reps = int_of_string (String.trim reps) in
189
Added:
match (Units.Weight.of_kg load, Units.Reps.of_int reps) with
190
Added:
| Ok load, Ok reps ->
191
Added:
Ok (Evidence.Stimulus.Warm_up.make ~exercise ~load ~reps)
192
Added:
| Error error, _ | _, Error error ->
193
Added:
Error (Format.asprintf "%a" Units.pp_error error)
194
Added:
with Failure _ -> Error "Each warm-up must be load,reps.")
195
Added:
| _ -> Error "Each warm-up must be load,reps."
196
Added:
in
197
Added:
List.fold_right
198
Added:
(fun line result ->
199
Added:
if String.trim line = "" then result
200
Added:
else
201
Added:
match (warm_up line, result) with
202
Added:
| Ok warm_up, Ok warm_ups -> Ok (warm_up :: warm_ups)
203
Added:
| Error error, _ | _, Error error -> Error error)
204
Added:
(String.split_on_char '\n' text)
205
Added:
(Ok [])
206
Added:
in
207
Added:
let save_stimulus record_id stimulus =
208
Added:
match record_id with
209
Added:
| None ->
210
Added:
Lwt.return
211
Added:
(match Service.log service stimulus with
212
Added:
| Ok workout -> Pages.log_workout ~record_id:None ~workout
213
Added:
| Error Service.No_workout_in_progress ->
214
Added:
Pages.problem ~title:"No workout in progress"
215
Added:
~detail:"Choose a routine to begin one."
216
Added:
| Error (Service.Rejected error) ->
217
Added:
Pages.problem ~title:"That is not what was prescribed"
218
Added:
~detail:(Format.asprintf "%a" Evidence.Workout.pp_error error))
219
Added:
| Some id ->
220
Added:
Lwt.return
221
Added:
(match Service.add_to_record service id stimulus with
222
Added:
| Ok record ->
223
Added:
Pages.log_workout
224
Added:
~record_id:(Some (record.Repository.id :> string))
225
Added:
~workout:record.Repository.workout
226
Added:
| Error Service.Unknown_workout ->
227
Added:
Pages.problem ~title:"Unknown workout"
228
Added:
~detail:"That saved workout no longer exists."
229
Added:
| Error (Service.Rejected_edit error) ->
230
Added:
Pages.problem ~title:"That is not what was prescribed"
231
Added:
~detail:(Format.asprintf "%a" Evidence.Workout.pp_error error))
232
Added:
in
86
233
87
234
Eliom_registration.Html.register ~service:Routes.log_single
88
Removed:
(fun () (slot, (load, (reps, extension))) ->
89
Removed:
match (Routes.extension_of_string extension, prescribed_at slot) with
235
Added:
(fun
236
Added:
() (workout_id, (slot, (load, (reps, (extension, (note, warm_ups)))))) ->
237
Added:
match
238
Added:
(Routes.extension_of_string extension, prescribed_at workout_id slot)
239
Added:
with
90
240
| Error bad, _ ->
91
241
Lwt.return
92
242
(Pages.problem ~title:"Unrecognised ending"
@@ -96,7 +246,7 @@
96
246
Lwt.return
97
247
(Pages.problem ~title:"No such outstanding stimulus"
98
248
~detail:"That slot is not awaiting a record.")
99
Removed:
| Ok extension, Some (_, prescription) -> (
249
Added:
| Ok extension, Some (record_id, prescription) -> (
100
250
match Prescription.Stimulus.delivery prescription with
101
251
| Prescription.Stimulus.Pre_exhaust _ ->
102
252
Lwt.return
@@ -104,19 +254,29 @@
104
254
~detail:
105
255
"A pre-exhaust pair cannot be recorded as a single set.")
106
256
| Prescription.Stimulus.Single exercise -> (
107
Removed:
match build_movement ~exercise ~load ~reps ~extension with
108
Removed:
| Error detail ->
257
Added:
match
258
Added:
( build_movement ~exercise ~load ~reps ~extension,
259
Added:
warm_ups_of_text ~exercise warm_ups )
260
Added:
with
261
Added:
| Error detail, _ | _, Error detail ->
109
262
Lwt.return (Pages.problem ~title:"Unusable figures" ~detail)
110
Removed:
| Ok movement ->
111
Removed:
logged
112
Removed:
(Service.log service
113
Removed:
(Evidence.Stimulus.make
114
Removed:
(Evidence.Stimulus.Single movement))))));
263
Added:
| Ok movement, Ok warm_ups ->
264
Added:
save_stimulus record_id
265
Added:
(Evidence.Stimulus.make ?note:(optional_text note) ~warm_ups
266
Added:
(Evidence.Stimulus.Single movement)))));
115
267
116
268
Eliom_registration.Html.register ~service:Routes.log_pair
117
269
(fun
118
Removed:
() (slot, (iso_load, (iso_reps, (comp_load, (comp_reps, extension))))) ->
119
Removed:
match (Routes.extension_of_string extension, prescribed_at slot) with
270
Added:
()
271
Added:
( workout_id,
272
Added:
( slot,
273
Added:
( iso_load,
274
Added:
(iso_reps, (comp_load, (comp_reps, (extension, (note, warm_ups)))))
275
Added:
) ) )
276
Added:
->
277
Added:
match
278
Added:
(Routes.extension_of_string extension, prescribed_at workout_id slot)
279
Added:
with
120
280
| Error bad, _ ->
121
281
Lwt.return
122
282
(Pages.problem ~title:"Unrecognised ending"
@@ -126,33 +286,68 @@
126
286
Lwt.return
127
287
(Pages.problem ~title:"No such outstanding stimulus"
128
288
~detail:"That slot is not awaiting a record.")
129
Removed:
| Ok extension, Some (_, prescription) -> (
289
Added:
| Ok extension, Some (record_id, prescription) -> (
130
290
match Prescription.Stimulus.delivery prescription with
131
291
| Prescription.Stimulus.Single _ ->
132
292
Lwt.return
133
293
(Pages.problem ~title:"That slot prescribes a single set"
134
294
~detail:"Only a pre-exhaust slot takes two movements.")
135
295
| Prescription.Stimulus.Pre_exhaust { isolation; compound } -> (
136
Removed:
(* HD1 applies the extension to the movement that finishes the
137
Removed:
pair, so it lands on the compound. *)
138
296
match
139
297
( build_movement ~exercise:isolation ~load:iso_load
140
298
~reps:iso_reps ~extension:None,
141
299
build_movement ~exercise:compound ~load:comp_load
142
Removed:
~reps:comp_reps ~extension )
300
Added:
~reps:comp_reps ~extension,
301
Added:
warm_ups_of_text ~exercise:isolation warm_ups )
143
302
with
144
Removed:
| Error detail, _ | _, Error detail ->
303
Added:
| Error detail, _, _ | _, Error detail, _ | _, _, Error detail ->
145
304
Lwt.return (Pages.problem ~title:"Unusable figures" ~detail)
146
Removed:
| Ok first, Ok second ->
147
Removed:
logged
148
Removed:
(Service.log service
149
Removed:
(Evidence.Stimulus.make
150
Removed:
(Evidence.Stimulus.Pair { first; second }))))));
305
Added:
| Ok first, Ok second, Ok warm_ups ->
306
Added:
save_stimulus record_id
307
Added:
(Evidence.Stimulus.make ?note:(optional_text note) ~warm_ups
308
Added:
(Evidence.Stimulus.Pair { first; second })))));
151
309
310
Added:
Eliom_registration.Html.register ~service:Routes.edit (fun workout_id () ->
311
Added:
let id = Repository.workout_id workout_id in
312
Added:
Lwt.return
313
Added:
(match Service.find_record service id with
314
Added:
| Some record ->
315
Added:
Pages.log_workout ~record_id:(Some workout_id)
316
Added:
~workout:record.Repository.workout
317
Added:
| None ->
318
Added:
Pages.problem ~title:"Unknown workout"
319
Added:
~detail:"That saved workout no longer exists."));
320
Added:
152
321
Eliom_registration.Html.register ~service:Routes.finish (fun () () ->
153
322
match Service.finish service ~ended_at:(now ()) with
154
Removed:
| Some _ -> Lwt.return (Pages.history ~records:(Service.history service))
323
Added:
| Some record -> Lwt.return (Pages.feedback ~record)
155
324
| None ->
156
325
Lwt.return
157
326
(Pages.problem ~title:"No workout in progress"
158
Removed:
~detail:"There was nothing to finish."))
327
Added:
~detail:"There was nothing to finish."));
328
Added:
329
Added:
Eliom_registration.Html.register ~service:Routes.feedback
330
Added:
(fun () (workout, rest) ->
331
Added:
let sleep, rest = rest in
332
Added:
let appetite, rest = rest in
333
Added:
let illness_stress, rest = rest in
334
Added:
let pain, rest = rest in
335
Added:
let pain_detail, rest = rest in
336
Added:
let motivation, rest = rest in
337
Added:
let recovery, rest = rest in
338
Added:
let difficulty, note = rest in
339
Added:
let id = Repository.workout_id workout in
340
Added:
Lwt.return
341
Added:
(match
342
Added:
feedback_of_strings ~sleep ~appetite ~illness_stress ~pain
343
Added:
~pain_detail ~motivation ~recovery ~difficulty ~note
344
Added:
with
345
Added:
| None ->
346
Added:
Pages.problem ~title:"Invalid feedback"
347
Added:
~detail:"Choose one of the offered answers."
348
Added:
| Some feedback -> (
349
Added:
match Service.set_feedback service id feedback with
350
Added:
| Ok _ -> Pages.history ~records:(Service.history service)
351
Added:
| Error _ ->
352
Added:
Pages.problem ~title:"Could not save feedback"
353
Added:
~detail:"The finished workout was not found.")))
test/test_evidence.ml
@@ -174,7 +174,7 @@
174
174
Alcotest.(check int)
175
175
"nothing outstanding" 0
176
176
(List.length (Workout.unperformed w));
177
Removed:
let finished = ok (Workout.finish w ~ended_at:(at 2400)) in
177
Added:
let finished = Workout.finish w ~ended_at:(at 2400) in
178
178
Alcotest.(check bool) "finished" true (Workout.is_finished finished);
179
179
Alcotest.(check (option int))
180
180
"40 minutes" (Some 2400)
@@ -192,16 +192,17 @@
192
192
(List.map
193
193
(fun s -> Exercise.name (List.hd (Stimulus.exercises s)))
194
194
(Workout.stimuli w)) );
195
Removed:
( "a finished workout accepts nothing further",
195
Added:
( "a finished workout remains editable and retains its end time",
196
196
`Quick,
197
197
fun () ->
198
Removed:
let w = ok (Workout.finish (fresh ()) ~ended_at:(at 60)) in
199
Removed:
(match Workout.add_stimulus w (single "laterals" 12. 8) with
200
Removed:
| Error Workout.Already_finished -> ()
201
Removed:
| _ -> Alcotest.fail "expected Already_finished");
202
Removed:
match Workout.finish w ~ended_at:(at 120) with
203
Removed:
| Error Workout.Already_finished -> ()
204
Removed:
| _ -> Alcotest.fail "expected Already_finished" );
198
Added:
let w = Workout.finish (fresh ()) ~ended_at:(at 60) in
199
Added:
let w = ok (Workout.add_stimulus w (single "laterals" 12. 8)) in
200
Added:
let w = Workout.finish w ~ended_at:(at 120) in
201
Added:
Alcotest.(check int)
202
Added:
"original end" 60
203
Added:
(Recovery.timestamp_to_unix_seconds (Option.get (Workout.ended_at w)));
204
Added:
Alcotest.(check int) "one recorded" 1 (List.length (Workout.stimuli w))
205
Added:
);
205
206
]
206
207
207
208
let conformance_tests =
@@ -317,7 +318,7 @@
317
318
(Workout.start p ~clearance:cleared ~started_at:on)
318
319
stimuli
319
320
in
320
Removed:
ok (Workout.finish w ~ended_at:on)
321
Added:
Workout.finish w ~ended_at:on
321
322
322
323
let laterals load r = single "laterals" load r
323
324
@@ -471,6 +472,83 @@
471
472
~recommended:Prescription.Routine.training_interval)) );
472
473
]
473
474
475
Added:
let completion_feedback_tests =
476
Added:
[
477
Added:
( "notes and multiple warm-ups are retained on the first stimulus",
478
Added:
`Quick,
479
Added:
fun () ->
480
Added:
let warm_up load count =
481
Added:
Stimulus.Warm_up.make ~exercise:(get "dumbbell-flyes") ~load:(kg load)
482
Added:
~reps:(reps count)
483
Added:
in
484
Added:
let stimulus =
485
Added:
Stimulus.make ~note:"controlled negative"
486
Added:
~warm_ups:[ warm_up 10. 12; warm_up 15. 8 ]
487
Added:
(Stimulus.Pair
488
Added:
{
489
Added:
first = move "dumbbell-flyes" 20. 9;
490
Added:
second = move "incline-press" 60. 7;
491
Added:
})
492
Added:
in
493
Added:
let workout = ok (Workout.add_stimulus (fresh ()) stimulus) in
494
Added:
let recorded = List.hd (Workout.stimuli workout) in
495
Added:
Alcotest.(check int)
496
Added:
"two warm-ups" 2
497
Added:
(List.length (Stimulus.warm_ups recorded));
498
Added:
Alcotest.(check (option string))
499
Added:
"note" (Some "controlled negative") (Stimulus.note recorded) );
500
Added:
( "warm-ups on a later prescribed stimulus are refused",
501
Added:
`Quick,
502
Added:
fun () ->
503
Added:
let workout = fresh () in
504
Added:
let warm_up =
505
Added:
Stimulus.Warm_up.make ~exercise:(get "laterals") ~load:(kg 5.)
506
Added:
~reps:(reps 10)
507
Added:
in
508
Added:
match
509
Added:
Workout.add_stimulus workout
510
Added:
(Stimulus.make ~warm_ups:[ warm_up ]
511
Added:
(Stimulus.Single (move "laterals" 12. 8)))
512
Added:
with
513
Added:
| Error Workout.Warm_ups_after_first_stimulus -> ()
514
Added:
| _ -> Alcotest.fail "expected warm-up placement rejection" );
515
Added:
( "feedback requires finish and completeness updates after later edits",
516
Added:
`Quick,
517
Added:
fun () ->
518
Added:
let feedback =
519
Added:
Workout.Feedback.make ~sleep:Workout.Feedback.Sleep_good
520
Added:
~appetite:Workout.Feedback.Appetite_ordinary
521
Added:
~illness_stress:Workout.Feedback.No_illness_or_stress
522
Added:
~pain_injury:false ~motivation:Workout.Feedback.Motivation_high
523
Added:
~recovery:Workout.Feedback.Recovery_good
524
Added:
~difficulty:Workout.Feedback.Difficulty_expected ()
525
Added:
in
526
Added:
Alcotest.(check bool)
527
Added:
"feedback rejected before finish" true
528
Added:
(Result.is_error (Workout.set_feedback (fresh ()) feedback));
529
Added:
let workout = Workout.finish (fresh ()) ~ended_at:(at 60) in
530
Added:
let workout = ok (Workout.set_feedback workout feedback) in
531
Added:
Alcotest.(check bool)
532
Added:
"incomplete" true
533
Added:
(match Workout.completeness workout with
534
Added:
| Workout.Incomplete -> true
535
Added:
| Complete -> false);
536
Added:
let workout =
537
Added:
List.fold_left
538
Added:
(fun w stimulus -> ok (Workout.add_stimulus w stimulus))
539
Added:
workout day_one_stimuli
540
Added:
in
541
Added:
Alcotest.(check bool)
542
Added:
"complete after edits" true
543
Added:
(match Workout.completeness workout with
544
Added:
| Workout.Complete -> true
545
Added:
| Incomplete -> false);
546
Added:
Alcotest.(check int)
547
Added:
"end time retained" 60
548
Added:
(Recovery.timestamp_to_unix_seconds
549
Added:
(Option.get (Workout.ended_at workout))) );
550
Added:
]
551
Added:
474
552
let suite =
475
553
[
476
554
("evidence.stimulus.outcome", outcome_tests);
@@ -480,6 +558,7 @@
480
558
("evidence.workout.conformance", conformance_tests);
481
559
("evidence.workout.volume", volume_tests);
482
560
("evidence.workout.clearance", clearance_tests);
561
Added:
("evidence.workout.completion_feedback", completion_feedback_tests);
483
562
("evidence.log.basics", log_basic_tests);
484
563
("evidence.log.observations", observation_tests);
485
564
("evidence.log.readiness", readiness_tests);
test/test_service.ml
@@ -172,6 +172,57 @@
172
172
Alcotest.(check int) "one workout" 1 (List.length (S.history s)) );
173
173
]
174
174
175
Added:
let active_and_edit_tests =
176
Added:
[
177
Added:
( "routine selection is explicit and rejects unknown IDs",
178
Added:
`Quick,
179
Added:
fun () ->
180
Added:
let s = service () in
181
Added:
Alcotest.(check bool)
182
Added:
"no initial selection" true
183
Added:
(Option.is_none (S.active_routine s));
184
Added:
ignore (ok (S.select_routine s ideal));
185
Added:
Alcotest.(check string)
186
Added:
"selected ideal" "Ideal Routine"
187
Added:
(Prescription.Routine.name (snd (Option.get (S.active_routine s))));
188
Added:
match S.select_routine s (Repository.routine_id "missing") with
189
Added:
| Error S.Unknown_routine -> ()
190
Added:
| _ -> Alcotest.fail "expected Unknown_routine" );
191
Added:
( "a finished record can be completed later without changing its end",
192
Added:
`Quick,
193
Added:
fun () ->
194
Added:
let s = service () in
195
Added:
ignore (ok (S.begin_workout s ~routine:ideal ~now:(day 1) ()));
196
Added:
let record = Option.get (S.finish s ~ended_at:(at 120)) in
197
Added:
let feedback =
198
Added:
Workout.Feedback.make ~sleep:Workout.Feedback.Sleep_ordinary
199
Added:
~appetite:Workout.Feedback.Appetite_ordinary
200
Added:
~illness_stress:Workout.Feedback.No_illness_or_stress
201
Added:
~pain_injury:false ~motivation:Workout.Feedback.Motivation_ordinary
202
Added:
~recovery:Workout.Feedback.Recovery_ordinary
203
Added:
~difficulty:Workout.Feedback.Difficulty_expected ()
204
Added:
in
205
Added:
let record = ok (S.set_feedback s record.Repository.id feedback) in
206
Added:
let record =
207
Added:
List.fold_left
208
Added:
(fun record stimulus ->
209
Added:
ok (S.add_to_record s record.Repository.id stimulus))
210
Added:
record day_one_stimuli
211
Added:
in
212
Added:
Alcotest.(check bool)
213
Added:
"complete" true
214
Added:
(match Workout.completeness record.Repository.workout with
215
Added:
| Workout.Complete -> true
216
Added:
| Incomplete -> false);
217
Added:
Alcotest.(check int)
218
Added:
"original end" 120
219
Added:
(Recovery.timestamp_to_unix_seconds
220
Added:
(Option.get (Workout.ended_at record.Repository.workout)));
221
Added:
Alcotest.(check bool)
222
Added:
"feedback retained" true
223
Added:
(Option.is_some (Workout.feedback record.Repository.workout)) );
224
Added:
]
225
Added:
175
226
let assessment_tests =
176
227
[
177
228
( "evidence accumulates across cycles and feeds progression",
@@ -230,5 +281,6 @@
230
281
("service.routines", routine_tests);
231
282
("service.clearance", clearance_tests);
232
283
("service.logging", logging_tests);
284
Added:
("service.active_and_edit", active_and_edit_tests);
233
285
("service.assessment", assessment_tests);
234
286
]