[OCaml] High Intensity Training Online
feat the HD1 flow in a browser
Choose a routine, be told when you have not recovered, log stimuli against what was prescribed, finish, and read it back. Server-rendered throughout: plain forms, no client-side OCaml. Routes live in their own module because Pages must link to them and Services must answer them; without the separation those two would depend on each other. It carries no .mli deliberately — an Eliom service type has eleven phantom parameters, and restating them per route would be a great deal of noise for no safety, since the types are inferred once and checked at every use. The recovery gate is two steps, as HD1 warrants. Attempting to begin while under-recovered does not start anything: it reports how much of the recommended rest remains and explains that growth happens during rest. Training anyway requires typing a reason, which is then shown on the workout page and kept with the entry for Progression to weigh later. Log forms are shaped by the prescription. A slot prescribing a pre-exhaust offers two movements with no rest between them and refuses to be recorded as a lone set; a single slot refuses the reverse. Entry gained `outstanding`, which pairs each unanswered prescription with its position — a form has to be able to name the slot it answers, and reconstructing that by physical equality would have depended on Entry's internals. Extensions attach to the movement that finishes a pair, which is where HD1 puts them. The form offers one extension where the domain permits a stack; a knowing limitation, noted for later. Paths are flat (/log-single, not /log/single): Eliom treats a path as either a page or a directory, and a page at /log cannot coexist with a child of it. Verified end to end against the running server: Day 1 begun on an empty log, a pec pre-exhaust recorded with forced reps, laterals recorded, the workout finished and read back from history, the next attempt refused with "rested 0s of the 2d this workout asks for", and an override accepted with its reason displayed. 132 Alcotests still pass.
Changed files
lib/core/entry.ml
@@ -87,10 +87,10 @@
87
87
88
88
let answered t = List.map fst t.performed
89
89
90
Removed:
let unperformed t =
91
Removed:
indexed t
92
Removed:
|> List.filter (fun (i, _) -> not (List.mem i (answered t)))
93
Removed:
|> List.map snd
90
Added:
let outstanding t =
91
Added:
indexed t |> List.filter (fun (i, _) -> not (List.mem i (answered t)))
92
Added:
93
Added:
let unperformed t = List.map snd (outstanding t)
94
94
95
95
let add_stimulus t s =
96
96
if is_finished t then Error Already_finished
lib/core/entry.mli
@@ -61,7 +61,12 @@
61
61
val stimuli : t -> Stimulus.t list
62
62
(** In the order performed. *)
63
63
64
Added:
val outstanding : t -> (int * Prescription.t) list
65
Added:
(** Prescribed stimuli this entry has yet to answer, each with its position in
66
Added:
the workout — a caller that offers to log one has to be able to say which.
67
Added:
*)
68
Added:
64
69
val unperformed : t -> Prescription.t list
65
Removed:
(** Prescribed stimuli this entry has yet to answer. *)
70
Added:
(** {!outstanding} without the positions. *)
66
71
67
72
val pp : Format.formatter -> t -> unit
lib/web/dune
@@ -4,5 +4,5 @@
4
4
(library
5
5
(name hito_web)
6
6
(public_name hito.web)
7
Removed:
(modules services)
8
Removed:
(libraries hito.core eliom.server))
7
Added:
(modules routes pages services)
8
Added:
(libraries hito.core hito.app eliom.server))
lib/web/pages.ml
@@ -0,0 +1,336 @@
1
Added:
open Eliom_content.Html.F
2
Added:
open Hito_app
3
Added:
4
Added:
type page = Html_types.html Eliom_content.Html.elt
5
Added:
6
Added:
(* Named so that inference cannot mistake a routine_id for a plain string at the
7
Added:
use sites. *)
8
Added:
let id_string (id : Repository.routine_id) = (id :> string)
9
Added:
10
Added:
(* Kept inline so the server needs no static file extension. *)
11
Added:
let stylesheet =
12
Added:
"*{box-sizing:border-box} body{font:16px/1.5 system-ui,sans-serif;margin:0 \
13
Added:
auto;max-width:34rem;padding:1rem;color:#191919;background:#fafafa} \
14
Added:
h1{font-size:1.4rem;margin:0 0 .25rem} h2{font-size:1.1rem;margin:1.5rem 0 \
15
Added:
.5rem} p{margin:.4rem 0} a{color:#0b5} nav{margin:.5rem 0 \
16
Added:
1.5rem;font-size:.9rem} nav a{margin-right:1rem} fieldset{border:1px solid \
17
Added:
#ddd;border-radius:6px;margin:0 0 1rem;padding:.75rem} \
18
Added:
legend{font-weight:600;padding:0 .35rem} label{display:block;margin:.4rem 0 \
19
Added:
.1rem;font-size:.85rem;color:#555} \
20
Added:
input,select{font:inherit;padding:.4rem;width:100%;border:1px solid \
21
Added:
#ccc;border-radius:4px;background:#fff} \
22
Added:
input[type=submit]{background:#191919;color:#fff;border:0;cursor:pointer;margin-top:.6rem;width:auto;padding:.5rem \
23
Added:
1rem} .row{display:flex;gap:.5rem} .row>div{flex:1} \
24
Added:
.warn{background:#fff6e5;border-left:3px solid #e59b00;padding:.6rem \
25
Added:
.8rem;margin:1rem 0} .done{color:#666;font-size:.9rem} \
26
Added:
ul{padding-left:1.2rem} li{margin:.2rem 0}"
27
Added:
28
Added:
let shell ~title:t content =
29
Added:
html
30
Added:
(head
31
Added:
(title (txt (t ^ " — hito")))
32
Added:
[
33
Added:
meta
34
Added:
~a:
35
Added:
[
36
Added:
a_name "viewport"; a_content "width=device-width,initial-scale=1";
37
Added:
]
38
Added:
();
39
Added:
style [ txt stylesheet ];
40
Added:
])
41
Added:
(body
42
Added:
([
43
Added:
h1 [ txt "hito" ];
44
Added:
nav
45
Added:
[
46
Added:
a ~service:Routes.home [ txt "Routines" ] ();
47
Added:
a ~service:Routes.log [ txt "Current workout" ] ();
48
Added:
a ~service:Routes.history [ txt "History" ] ();
49
Added:
];
50
Added:
]
51
Added:
@ content))
52
Added:
53
Added:
let problem ~title:t ~detail =
54
Added:
shell ~title:t [ h2 [ txt t ]; p ~a:[ a_class [ "warn" ] ] [ txt detail ] ]
55
Added:
56
Added:
(* A prescription described in words: the movements, and the rep window that
57
Added:
calibrates the load. *)
58
Added:
let describe_prescription p =
59
Added:
let window =
60
Added:
Format.asprintf "%a reps" Units.Rep_range.pp (Prescription.rep_range p)
61
Added:
in
62
Added:
match Prescription.delivery p with
63
Added:
| Prescription.Single e -> Printf.sprintf "%s — %s" (Exercise.name e) window
64
Added:
| Prescription.Pre_exhaust { isolation; compound } ->
65
Added:
Printf.sprintf "%s into %s, no pause — %s" (Exercise.name isolation)
66
Added:
(Exercise.name compound) window
67
Added:
68
Added:
let extension_select name =
69
Added:
match
70
Added:
List.map
71
Added:
(fun (value, label) -> Form.Option ([], value, Some (txt label), false))
72
Added:
Routes.extension_choices
73
Added:
with
74
Added:
| first :: rest -> Form.select ~name Form.string first rest
75
Added:
| [] -> assert false
76
Added:
77
Added:
let choose_routine ~(routines : (Repository.routine_id * Routine.t) list) =
78
Added:
shell ~title:"Choose a routine"
79
Added:
[
80
Added:
h2 [ txt "Routines" ];
81
Added:
div
82
Added:
(List.map
83
Added:
(fun (id, r) ->
84
Added:
Form.post_form ~service:Routes.begin_workout
85
Added:
(fun (routine, reason) ->
86
Added:
[
87
Added:
fieldset
88
Added:
~legend:(legend [ txt (Routine.name r) ])
89
Added:
[
90
Added:
p
91
Added:
[
92
Added:
txt
93
Added:
(Printf.sprintf "%d workouts in the cycle."
94
Added:
(List.length (Routine.workouts r)));
95
Added:
];
96
Added:
Form.input ~input_type:`Hidden ~name:routine
97
Added:
~value:(id_string id) Form.string;
98
Added:
Form.input ~input_type:`Hidden ~name:reason ~value:""
99
Added:
Form.string;
100
Added:
Form.input ~input_type:`Submit
101
Added:
~value:"Begin next workout" Form.string;
102
Added:
];
103
Added:
])
104
Added:
())
105
Added:
routines);
106
Added:
]
107
Added:
108
Added:
let recovery_gate ~(routine : Repository.routine_id) ~workout ~readiness =
109
Added:
let remaining =
110
Added:
match readiness with
111
Added:
| Recovery.Ready -> "Recovery is complete."
112
Added:
| Recovery.Recovering { rested; recommended } ->
113
Added:
Format.asprintf "You have rested %a of the %a this workout asks for."
114
Added:
Recovery.pp_duration rested Recovery.pp_duration recommended
115
Added:
in
116
Added:
shell ~title:"Not recovered"
117
Added:
[
118
Added:
h2 [ txt ("Next: " ^ Workout_prescription.name workout) ];
119
Added:
div
120
Added:
~a:[ a_class [ "warn" ] ]
121
Added:
[
122
Added:
p [ txt remaining ];
123
Added:
p
124
Added:
[
125
Added:
txt
126
Added:
"Heavy Duty treats training before recovery finishes as the \
127
Added:
main way progress is lost — growth happens while you rest, \
128
Added:
not while you lift. Train anyway only with a reason, which is \
129
Added:
kept with the workout so a later stall can be explained.";
130
Added:
];
131
Added:
];
132
Added:
Form.post_form ~service:Routes.begin_workout
133
Added:
(fun (routine_name, reason) ->
134
Added:
[
135
Added:
fieldset
136
Added:
~legend:(legend [ txt "Train anyway" ])
137
Added:
[
138
Added:
Form.input ~input_type:`Hidden ~name:routine_name
139
Added:
~value:(id_string routine) Form.string;
140
Added:
label
141
Added:
~a:[ a_label_for "reason" ]
142
Added:
[ txt "Why are you training early?" ];
143
Added:
Form.input
144
Added:
~a:
145
Added:
[
146
Added:
a_id "reason";
147
Added:
a_required ();
148
Added:
a_placeholder "travelling tomorrow";
149
Added:
]
150
Added:
~input_type:`Text ~name:reason Form.string;
151
Added:
Form.input ~input_type:`Submit ~value:"Begin under override"
152
Added:
Form.string;
153
Added:
];
154
Added:
])
155
Added:
();
156
Added:
]
157
Added:
158
Added:
let single_form ~slot ~prescription =
159
Added:
Form.post_form ~service:Routes.log_single
160
Added:
(fun (slot_name, (load_name, (reps_name, ext_name))) ->
161
Added:
[
162
Added:
fieldset
163
Added:
~legend:(legend [ txt (describe_prescription prescription) ])
164
Added:
[
165
Added:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
166
Added:
div
167
Added:
~a:[ a_class [ "row" ] ]
168
Added:
[
169
Added:
div
170
Added:
[
171
Added:
label ~a:[ a_label_for "l" ] [ txt "Load (kg)" ];
172
Added:
Form.input
173
Added:
~a:[ a_id "l"; a_step (Some 0.5); a_required () ]
174
Added:
~input_type:`Number ~name:load_name Form.float;
175
Added:
];
176
Added:
div
177
Added:
[
178
Added:
label ~a:[ a_label_for "r" ] [ txt "Reps to failure" ];
179
Added:
Form.input
180
Added:
~a:[ a_id "r"; a_required () ]
181
Added:
~input_type:`Number ~name:reps_name Form.int;
182
Added:
];
183
Added:
];
184
Added:
label [ txt "Ending" ];
185
Added:
extension_select ext_name;
186
Added:
Form.input ~input_type:`Submit ~value:"Record" Form.string;
187
Added:
];
188
Added:
])
189
Added:
()
190
Added:
191
Added:
let pair_form ~slot ~prescription ~isolation ~compound =
192
Added:
Form.post_form ~service:Routes.log_pair
193
Added:
(fun (slot_name, (iso_load, (iso_reps, (comp_load, (comp_reps, ext_name)))))
194
Added:
->
195
Added:
[
196
Added:
fieldset
197
Added:
~legend:(legend [ txt (describe_prescription prescription) ])
198
Added:
[
199
Added:
Form.input ~input_type:`Hidden ~name:slot_name ~value:slot Form.int;
200
Added:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name isolation) ];
201
Added:
div
202
Added:
~a:[ a_class [ "row" ] ]
203
Added:
[
204
Added:
div
205
Added:
[
206
Added:
label [ txt "Load (kg)" ];
207
Added:
Form.input
208
Added:
~a:[ a_step (Some 0.5); a_required () ]
209
Added:
~input_type:`Number ~name:iso_load Form.float;
210
Added:
];
211
Added:
div
212
Added:
[
213
Added:
label [ txt "Reps" ];
214
Added:
Form.input
215
Added:
~a:[ a_required () ]
216
Added:
~input_type:`Number ~name:iso_reps Form.int;
217
Added:
];
218
Added:
];
219
Added:
p ~a:[ a_class [ "done" ] ] [ txt (Exercise.name compound) ];
220
Added:
div
221
Added:
~a:[ a_class [ "row" ] ]
222
Added:
[
223
Added:
div
224
Added:
[
225
Added:
label [ txt "Load (kg)" ];
226
Added:
Form.input
227
Added:
~a:[ a_step (Some 0.5); a_required () ]
228
Added:
~input_type:`Number ~name:comp_load Form.float;
229
Added:
];
230
Added:
div
231
Added:
[
232
Added:
label [ txt "Reps" ];
233
Added:
Form.input
234
Added:
~a:[ a_required () ]
235
Added:
~input_type:`Number ~name:comp_reps Form.int;
236
Added:
];
237
Added:
];
238
Added:
label [ txt "Ending" ];
239
Added:
extension_select ext_name;
240
Added:
Form.input ~input_type:`Submit ~value:"Record" Form.string;
241
Added:
];
242
Added:
])
243
Added:
()
244
Added:
245
Added:
let describe_stimulus s =
246
Added:
let movement m =
247
Added:
Format.asprintf "%s %a x %a"
248
Added:
(Exercise.name (Stimulus.Movement.exercise m))
249
Added:
Units.Weight.pp (Stimulus.Movement.load m) Units.Reps.pp
250
Added:
(Stimulus.Movement.reps m)
251
Added:
in
252
Added:
let body =
253
Added:
String.concat " into " (List.map movement (Stimulus.movements s))
254
Added:
in
255
Added:
match Stimulus.extensions s with
256
Added:
| [] -> body
257
Added:
| es ->
258
Added:
body ^ ", "
259
Added:
^ String.concat " then "
260
Added:
(List.map (Format.asprintf "%a" Stimulus.pp_extension) es)
261
Added:
262
Added:
let log_workout ~entry =
263
Added:
let prescription = Entry.prescription entry in
264
Added:
let performed = Entry.stimuli entry in
265
Added:
let outstanding = Entry.outstanding entry in
266
Added:
let override_note =
267
Added:
match Recovery.basis (Entry.clearance entry) with
268
Added:
| Recovery.Recovered -> []
269
Added:
| Recovery.Overridden { reason; _ } ->
270
Added:
[
271
Added:
div
272
Added:
~a:[ a_class [ "warn" ] ]
273
Added:
[ txt ("Begun before recovery finished: " ^ reason) ];
274
Added:
]
275
Added:
in
276
Added:
shell
277
Added:
~title:(Workout_prescription.name prescription)
278
Added:
(override_note
279
Added:
@ [
280
Added:
h2 [ txt (Workout_prescription.name prescription) ];
281
Added:
p
282
Added:
[
283
Added:
txt
284
Added:
(Printf.sprintf "%d of %d recorded." (List.length performed)
285
Added:
(List.length (Workout_prescription.prescriptions prescription)));
286
Added:
];
287
Added:
]
288
Added:
@ (if performed = [] then []
289
Added:
else
290
Added:
[
291
Added:
h2 [ txt "Recorded" ];
292
Added:
ul (List.map (fun s -> li [ txt (describe_stimulus s) ]) performed);
293
Added:
])
294
Added:
@ (if outstanding = [] then
295
Added:
[ p [ txt "Everything prescribed has been recorded." ] ]
296
Added:
else
297
Added:
h2 [ txt "Still to do" ]
298
Added:
:: List.map
299
Added:
(fun (slot, p) ->
300
Added:
match Prescription.delivery p with
301
Added:
| Prescription.Single _ -> single_form ~slot ~prescription:p
302
Added:
| Prescription.Pre_exhaust { isolation; compound } ->
303
Added:
pair_form ~slot ~prescription:p ~isolation ~compound)
304
Added:
outstanding)
305
Added:
@ [
306
Added:
Form.post_form ~service:Routes.finish
307
Added:
(fun () ->
308
Added:
[
309
Added:
Form.input ~input_type:`Submit ~value:"Finish workout" Form.string;
310
Added:
])
311
Added:
();
312
Added:
])
313
Added:
314
Added:
let history ~records =
315
Added:
shell ~title:"History"
316
Added:
[
317
Added:
h2 [ txt "History" ];
318
Added:
(if records = [] then p [ txt "Nothing logged yet." ]
319
Added:
else
320
Added:
ul
321
Added:
(List.map
322
Added:
(fun r ->
323
Added:
let e = r.Repository.entry in
324
Added:
li
325
Added:
[
326
Added:
txt
327
Added:
(Printf.sprintf "%s — %d stimuli"
328
Added:
(Workout_prescription.name (Entry.prescription e))
329
Added:
(List.length (Entry.stimuli e)));
330
Added:
ul
331
Added:
(List.map
332
Added:
(fun s -> li [ txt (describe_stimulus s) ])
333
Added:
(Entry.stimuli e));
334
Added:
])
335
Added:
records));
336
Added:
]
lib/web/pages.mli
@@ -0,0 +1,28 @@
1
Added:
(** Page rendering. Pure view functions: they read what they are given and
2
Added:
return HTML, and do nothing else. All domain access happens in {!Services}.
3
Added:
*)
4
Added:
5
Added:
open Hito_app
6
Added:
7
Added:
type page = Html_types.html Eliom_content.Html.elt
8
Added:
9
Added:
val choose_routine : routines:(Repository.routine_id * Routine.t) list -> page
10
Added:
11
Added:
val recovery_gate :
12
Added:
routine:Repository.routine_id ->
13
Added:
workout:Workout_prescription.t ->
14
Added:
readiness:Recovery.readiness ->
15
Added:
page
16
Added:
(** The refusal. States how much of the recommended rest remains, and offers to
17
Added:
start anyway only once a reason has been given — HD1 treats training before
18
Added:
recovery as the primary error, so it is deliberately a second step rather
19
Added:
than one click. *)
20
Added:
21
Added:
val log_workout : entry:Entry.t -> page
22
Added:
(** The workout in progress: what is outstanding, what has been performed, and a
23
Added:
form per outstanding stimulus. *)
24
Added:
25
Added:
val history : records:Repository.record list -> page
26
Added:
27
Added:
val problem : title:string -> detail:string -> page
28
Added:
(** Something the request asked for could not be done. *)
lib/web/routes.ml
@@ -0,0 +1,81 @@
1
Added:
(* Route declarations, kept apart from both the pages that link to them and the
2
Added:
handlers that answer them — otherwise Pages and Services would depend on each
3
Added:
other.
4
Added:
5
Added:
This module deliberately has no .mli. An Eliom service type carries eleven
6
Added:
phantom parameters, and restating them per route would cost a great deal of
7
Added:
noise for no safety: the types are inferred here and checked at every use. *)
8
Added:
9
Added:
(* Extensions arrive as form values. Parsing is total and rejects anything the
10
Added:
form did not offer, rather than silently dropping it. *)
11
Added:
let extension_of_string = function
12
Added:
| "" -> Ok None
13
Added:
| "forced" -> Ok (Some Stimulus.Forced_reps)
14
Added:
| "negatives" -> Ok (Some Stimulus.Negatives)
15
Added:
| "rest-pause" -> Ok (Some Stimulus.Rest_pause)
16
Added:
| "static" -> Ok (Some Stimulus.Static_hold)
17
Added:
| other -> Error other
18
Added:
19
Added:
let extension_choices =
20
Added:
[
21
Added:
("", "to positive failure");
22
Added:
("forced", "then forced reps");
23
Added:
("negatives", "then negatives");
24
Added:
("rest-pause", "then rest-pause");
25
Added:
("static", "then a static hold");
26
Added:
]
27
Added:
28
Added:
(* GET / — choose a routine, or resume what is in progress. *)
29
Added:
let home =
30
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "" ])
31
Added:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
32
Added:
33
Added:
(* GET /log — the workout in progress. *)
34
Added:
let log =
35
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "log" ])
36
Added:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
37
Added:
38
Added:
(* GET /history — what has been performed. *)
39
Added:
let history =
40
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "history" ])
41
Added:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
42
Added:
43
Added:
(* POST /begin — start the next workout. An empty reason means "no override
44
Added:
offered", which is how the two-step gate refuses the first attempt. *)
45
Added:
let begin_workout =
46
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "begin" ])
47
Added:
~meth:
48
Added:
(Eliom_service.Post
49
Added:
( Eliom_parameter.unit,
50
Added:
Eliom_parameter.(string "routine" ** string "reason") ))
51
Added:
()
52
Added:
53
Added:
(* POST /log-single — one movement driven to failure.
54
Added:
55
Added:
Paths are flat: Eliom treats a path as either a page or a directory, so a
56
Added:
page at /log cannot coexist with /log/single. *)
57
Added:
let log_single =
58
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "log-single" ])
59
Added:
~meth:
60
Added:
(Eliom_service.Post
61
Added:
( Eliom_parameter.unit,
62
Added:
Eliom_parameter.(
63
Added:
int "slot" ** float "load" ** int "reps" ** string "extension") ))
64
Added:
()
65
Added:
66
Added:
(* POST /log-pair — an isolation carried into a compound, no pause between. *)
67
Added:
let log_pair =
68
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "log-pair" ])
69
Added:
~meth:
70
Added:
(Eliom_service.Post
71
Added:
( Eliom_parameter.unit,
72
Added:
Eliom_parameter.(
73
Added:
int "slot" ** float "iso_load" ** int "iso_reps"
74
Added:
** float "comp_load" ** int "comp_reps" ** string "extension") ))
75
Added:
()
76
Added:
77
Added:
(* POST /finish — complete and persist. *)
78
Added:
let finish =
79
Added:
Eliom_service.create ~path:(Eliom_service.Path [ "finish" ])
80
Added:
~meth:(Eliom_service.Post (Eliom_parameter.unit, Eliom_parameter.unit))
81
Added:
()
lib/web/services.ml
@@ -1,15 +1,164 @@
1
Removed:
open Eliom_content.Html.F
1
Added:
open Hito_app
2
Added:
module Service = Service.Make (Memory_repo)
2
3
3
Removed:
(* GET / *)
4
Removed:
let home =
5
Removed:
Eliom_service.create ~path:(Eliom_service.Path [ "" ])
6
Removed:
~meth:(Eliom_service.Get Eliom_parameter.unit) ()
4
Added:
(* One process, one trainee. The store and the workout in progress live for the
5
Added:
lifetime of the server; nothing survives a restart. Both become per-trainee
6
Added:
when authentication exists. *)
7
Added:
let service = Service.make ~repo:(Memory_repo.create ())
7
8
8
Removed:
let page ~title:t body_content =
9
Removed:
html (head (title (txt t)) []) (body body_content)
9
Added:
(* The core is pure and has no clock, so wall-clock time enters here. *)
10
Added:
let now () =
11
Added:
Recovery.timestamp_of_unix_seconds (int_of_float (Unix.gettimeofday ()))
10
12
13
Added:
let home_page () =
14
Added:
match Service.in_progress service with
15
Added:
| Some entry -> Pages.log_workout ~entry
16
Added:
| None -> Pages.choose_routine ~routines:(Service.list_routines service)
17
Added:
11
18
let register () =
12
Removed:
Eliom_registration.Html.register ~service:home (fun () () ->
19
Added:
Eliom_registration.Html.register ~service:Routes.home (fun () () ->
20
Added:
Lwt.return (home_page ()));
21
Added:
22
Added:
Eliom_registration.Html.register ~service:Routes.log (fun () () ->
13
23
Lwt.return
14
Removed:
(page ~title:"hito"
15
Removed:
[ h1 [ txt "hito" ]; p [ txt "High Intensity Trainer Online" ] ]))
24
Added:
(match Service.in_progress service with
25
Added:
| Some entry -> Pages.log_workout ~entry
26
Added:
| None ->
27
Added:
Pages.problem ~title:"No workout in progress"
28
Added:
~detail:"Choose a routine to begin one."));
29
Added:
30
Added:
Eliom_registration.Html.register ~service:Routes.history (fun () () ->
31
Added:
Lwt.return (Pages.history ~records:(Service.history service)));
32
Added:
33
Added:
(* Begin. An empty reason means none was offered, which is what makes the
34
Added:
recovery gate a deliberate second step rather than one click. *)
35
Added:
Eliom_registration.Html.register ~service:Routes.begin_workout
36
Added:
(fun () (routine, reason) ->
37
Added:
let routine = Repository.routine_id routine in
38
Added:
let override = if String.trim reason = "" then None else Some reason in
39
Added:
Lwt.return
40
Added:
(match
41
Added:
Service.begin_workout service ~routine ~now:(now ()) ?override ()
42
Added:
with
43
Added:
| Ok entry -> Pages.log_workout ~entry
44
Added:
| Error (Service.Not_recovered readiness) -> (
45
Added:
match Service.next_workout service ~routine with
46
Added:
| Ok workout -> Pages.recovery_gate ~routine ~workout ~readiness
47
Added:
| Error _ ->
48
Added:
Pages.problem ~title:"Unknown routine"
49
Added:
~detail:"That routine is not in the catalogue.")
50
Added:
| Error Service.Unknown_routine ->
51
Added:
Pages.problem ~title:"Unknown routine"
52
Added:
~detail:"That routine is not in the catalogue."));
53
Added:
54
Added:
let logged result =
55
Added:
Lwt.return
56
Added:
(match result with
57
Added:
| Ok entry -> Pages.log_workout ~entry
58
Added:
| Error Service.No_workout_in_progress ->
59
Added:
Pages.problem ~title:"No workout in progress"
60
Added:
~detail:"Choose a routine to begin one."
61
Added:
| Error (Service.Rejected e) ->
62
Added:
Pages.problem ~title:"That is not what was prescribed"
63
Added:
~detail:(Format.asprintf "%a" Entry.pp_error e))
64
Added:
in
65
Added:
66
Added:
let build_movement ~exercise ~load ~reps ~extension =
67
Added:
match (Units.Weight.of_kg load, Units.Reps.of_int reps) with
68
Added:
| Ok load, Ok reps ->
69
Added:
let outcome =
70
Added:
match extension with
71
Added:
| None -> Stimulus.Positive_failure
72
Added:
| Some e -> Stimulus.Beyond_failure (e, [])
73
Added:
in
74
Added:
Ok (Stimulus.Movement.make ~exercise ~load ~reps ~outcome)
75
Added:
| Error e, _ | _, Error e -> Error (Format.asprintf "%a" Units.pp_error e)
76
Added:
in
77
Added:
78
Added:
(* The slot names which prescribed stimulus is being answered. *)
79
Added:
let prescribed_at slot =
80
Added:
match Service.in_progress service with
81
Added:
| None -> None
82
Added:
| Some entry ->
83
Added:
List.assoc_opt slot (Entry.outstanding entry)
84
Added:
|> Option.map (fun p -> (entry, p))
85
Added:
in
86
Added:
87
Added:
Eliom_registration.Html.register ~service:Routes.log_single
88
Added:
(fun () (slot, (load, (reps, extension))) ->
89
Added:
match (Routes.extension_of_string extension, prescribed_at slot) with
90
Added:
| Error bad, _ ->
91
Added:
Lwt.return
92
Added:
(Pages.problem ~title:"Unrecognised ending"
93
Added:
~detail:
94
Added:
(Printf.sprintf "%S is not one of the offered choices." bad))
95
Added:
| Ok _, None ->
96
Added:
Lwt.return
97
Added:
(Pages.problem ~title:"No such outstanding stimulus"
98
Added:
~detail:"That slot is not awaiting a record.")
99
Added:
| Ok extension, Some (_, prescription) -> (
100
Added:
match Prescription.delivery prescription with
101
Added:
| Prescription.Pre_exhaust _ ->
102
Added:
Lwt.return
103
Added:
(Pages.problem ~title:"That slot prescribes a pair"
104
Added:
~detail:
105
Added:
"A pre-exhaust pair cannot be recorded as a single set.")
106
Added:
| Prescription.Single exercise -> (
107
Added:
match build_movement ~exercise ~load ~reps ~extension with
108
Added:
| Error detail ->
109
Added:
Lwt.return (Pages.problem ~title:"Unusable figures" ~detail)
110
Added:
| Ok movement -> (
111
Added:
match Stimulus.make (Stimulus.Single movement) with
112
Added:
| Error e ->
113
Added:
Lwt.return
114
Added:
(Pages.problem ~title:"Could not record"
115
Added:
~detail:(Format.asprintf "%a" Stimulus.pp_error e))
116
Added:
| Ok stimulus -> logged (Service.log service stimulus)))));
117
Added:
118
Added:
Eliom_registration.Html.register ~service:Routes.log_pair
119
Added:
(fun
120
Added:
() (slot, (iso_load, (iso_reps, (comp_load, (comp_reps, extension))))) ->
121
Added:
match (Routes.extension_of_string extension, prescribed_at slot) with
122
Added:
| Error bad, _ ->
123
Added:
Lwt.return
124
Added:
(Pages.problem ~title:"Unrecognised ending"
125
Added:
~detail:
126
Added:
(Printf.sprintf "%S is not one of the offered choices." bad))
127
Added:
| Ok _, None ->
128
Added:
Lwt.return
129
Added:
(Pages.problem ~title:"No such outstanding stimulus"
130
Added:
~detail:"That slot is not awaiting a record.")
131
Added:
| Ok extension, Some (_, prescription) -> (
132
Added:
match Prescription.delivery prescription with
133
Added:
| Prescription.Single _ ->
134
Added:
Lwt.return
135
Added:
(Pages.problem ~title:"That slot prescribes a single set"
136
Added:
~detail:"Only a pre-exhaust slot takes two movements.")
137
Added:
| Prescription.Pre_exhaust { isolation; compound } -> (
138
Added:
(* HD1 applies the extension to the movement that finishes the
139
Added:
pair, so it lands on the compound. *)
140
Added:
match
141
Added:
( build_movement ~exercise:isolation ~load:iso_load
142
Added:
~reps:iso_reps ~extension:None,
143
Added:
build_movement ~exercise:compound ~load:comp_load
144
Added:
~reps:comp_reps ~extension )
145
Added:
with
146
Added:
| Error detail, _ | _, Error detail ->
147
Added:
Lwt.return (Pages.problem ~title:"Unusable figures" ~detail)
148
Added:
| Ok isolation, Ok compound -> (
149
Added:
match
150
Added:
Stimulus.make (Stimulus.Pre_exhaust { isolation; compound })
151
Added:
with
152
Added:
| Error e ->
153
Added:
Lwt.return
154
Added:
(Pages.problem ~title:"Could not record"
155
Added:
~detail:(Format.asprintf "%a" Stimulus.pp_error e))
156
Added:
| Ok stimulus -> logged (Service.log service stimulus)))));
157
Added:
158
Added:
Eliom_registration.Html.register ~service:Routes.finish (fun () () ->
159
Added:
match Service.finish service ~ended_at:(now ()) with
160
Added:
| Some _ -> Lwt.return (Pages.history ~records:(Service.history service))
161
Added:
| None ->
162
Added:
Lwt.return
163
Added:
(Pages.problem ~title:"No workout in progress"
164
Added:
~detail:"There was nothing to finish."))