[OCaml] High Intensity Training Online
feat month/year picker with prev/next/Now navigation
Replace the calendar's static month label with month and year dropdowns and prev/next/Now links. Selecting a month drives both the calendar and the logbook table: only that month's entries fill the table. The picker's year range spans the earliest logged year through the present.
Changed files
lib/presenter/pages_logbook.ml
@@ -298,22 +298,83 @@
298
298
else [])
299
299
[ txt "%d" d.day_of_month ]
300
300
in
301
Removed:
tag "table"
302
Removed:
[ class_ "calendar" ]
301
Added:
let option_ ~selected value label =
302
Added:
tag "option"
303
Added:
([ Dream_html.string_attr "value" "%d" value ]
304
Added:
@ if value = selected then [ Dream_html.attr "selected" ] else [])
305
Added:
[ txt "%s" label ]
306
Added:
in
307
Added:
let picker =
308
Added:
tag "form"
309
Added:
[ action Routes.logbook; class_ "calendar-picker" ]
310
Added:
[
311
Added:
tag "select"
312
Added:
[ name "month"; Dream_html.string_attr "aria-label" "Month" ]
313
Added:
(List.map
314
Added:
(fun (n, nm) -> option_ ~selected:cal.selected_month n nm)
315
Added:
cal.months);
316
Added:
tag "select"
317
Added:
[ name "year"; Dream_html.string_attr "aria-label" "Year" ]
318
Added:
(List.map
319
Added:
(fun y -> option_ ~selected:cal.selected_year y (string_of_int y))
320
Added:
cal.years);
321
Added:
tag "button" [ type_ "submit" ] [ txt "Show" ];
322
Added:
]
323
Added:
in
324
Added:
let prev_month =
325
Added:
if cal.selected_month = 1 then (cal.selected_year - 1, 12)
326
Added:
else (cal.selected_year, cal.selected_month - 1)
327
Added:
in
328
Added:
let next_month =
329
Added:
if cal.selected_month = 12 then (cal.selected_year + 1, 1)
330
Added:
else (cal.selected_year, cal.selected_month + 1)
331
Added:
in
332
Added:
let nav_link ~label (y, m) rel =
333
Added:
tag "a"
334
Added:
[
335
Added:
Dream_html.string_attr "href" "/logbook?year=%d&month=%d" y m;
336
Added:
class_ "calendar-nav-link";
337
Added:
Dream_html.attr "data-hito-app-link";
338
Added:
Dream_html.string_attr "aria-label" "%s" rel;
339
Added:
]
340
Added:
[ txt "%s" label ]
341
Added:
in
342
Added:
let nav =
343
Added:
tag "div"
344
Added:
[ class_ "calendar-nav" ]
345
Added:
[
346
Added:
nav_link ~label:"‹" prev_month "Previous month";
347
Added:
tag "a"
348
Added:
[
349
Added:
href Routes.logbook;
350
Added:
class_ "calendar-nav-now";
351
Added:
Dream_html.attr "data-hito-app-link";
352
Added:
]
353
Added:
[ txt "Now" ];
354
Added:
nav_link ~label:"›" next_month "Next month";
355
Added:
]
356
Added:
in
357
Added:
tag "div"
358
Added:
[ class_ "calendar-block" ]
303
359
[
304
Removed:
tag "caption" [ class_ "calendar-caption" ] [ txt "%s" cal.month_label ];
305
Removed:
tag "thead" []
360
Added:
nav;
361
Added:
picker;
362
Added:
tag "table"
363
Added:
[ class_ "calendar" ]
306
364
[
307
Removed:
tag "tr" []
308
Removed:
(List.map
309
Removed:
(fun h ->
310
Removed:
tag "th"
311
Removed:
[ Dream_html.string_attr "scope" "col" ]
312
Removed:
[ txt "%s" h ])
313
Removed:
cal.weekday_headings);
365
Added:
tag "thead" []
366
Added:
[
367
Added:
tag "tr" []
368
Added:
(List.map
369
Added:
(fun h ->
370
Added:
tag "th"
371
Added:
[ Dream_html.string_attr "scope" "col" ]
372
Added:
[ txt "%s" h ])
373
Added:
cal.weekday_headings);
374
Added:
];
375
Added:
tag "tbody" []
376
Added:
(List.map (fun week -> tag "tr" [] (List.map cell week)) cal.weeks);
314
377
];
315
Removed:
tag "tbody" []
316
Removed:
(List.map (fun week -> tag "tr" [] (List.map cell week)) cal.weeks);
317
378
]
318
379
319
380
let logbook request ?(logging = false) ~viewer ?(feedback = []) ?calendar
lib/presenter/view_model.ml
@@ -192,12 +192,16 @@
192
192
outside the month. *)
193
193
194
194
type t = {
195
Removed:
month_label : string; (** "September 2026", already formatted. *)
195
Added:
selected_year : int;
196
Added:
selected_month : int; (** 1..12. *)
197
Added:
months : (int * string) list; (** (number, name) for the month dropdown. *)
198
Added:
years : int list; (** Selectable years, ascending. *)
196
199
weekday_headings : string list; (** Seven short labels, Monday first. *)
197
200
weeks : cell list list; (** Rows of seven cells, Monday first. *)
198
201
}
199
Removed:
(** A single month laid out as a week grid, shown above the logbook. The
200
Removed:
handler does the date arithmetic; the presenter only renders the grid. *)
202
Added:
(** A single month laid out as a week grid, above the logbook, with month and
203
Added:
year dropdowns to choose which month to show. The handler does the date
204
Added:
arithmetic; the presenter renders the grid and the picker. *)
201
205
end
202
206
203
207
module Progress_page = struct
lib/web/assets/hito.css
@@ -735,19 +735,42 @@
735
735
736
736
/* The month calendar above the logbook. A fixed seven-column grid; days with a
737
737
workout are filled oxblood, today is ringed. */
738
Removed:
.calendar {
739
Removed:
width: 100%;
738
Added:
.calendar-block {
740
739
max-width: 22rem;
741
740
margin: 0 auto 1.5rem;
742
Removed:
border-collapse: collapse;
743
Removed:
table-layout: fixed;
744
741
}
745
Removed:
.calendar-caption {
746
Removed:
caption-side: top;
742
Added:
.calendar-picker {
743
Added:
display: flex;
744
Added:
gap: 0.5rem;
745
Added:
align-items: center;
747
746
margin-bottom: 0.5rem;
748
Removed:
color: var(--ink);
749
Removed:
font: 700 var(--font-size-lead)/1.2 var(--sans);
750
Removed:
text-align: left;
747
Added:
}
748
Added:
.calendar-picker select { flex: 1 1 auto; }
749
Added:
.calendar-picker button { flex: 0 0 auto; }
750
Added:
.calendar-nav {
751
Added:
display: flex;
752
Added:
align-items: center;
753
Added:
justify-content: space-between;
754
Added:
gap: 0.5rem;
755
Added:
margin-bottom: 0.4rem;
756
Added:
}
757
Added:
.calendar-nav-link,
758
Added:
.calendar-nav-now {
759
Added:
display: inline-flex;
760
Added:
align-items: center;
761
Added:
min-height: 2.25rem;
762
Added:
padding: 0 0.6rem;
763
Added:
border-radius: var(--radius);
764
Added:
color: var(--oxblood-dark);
765
Added:
font-weight: 700;
766
Added:
text-decoration: none;
767
Added:
}
768
Added:
.calendar-nav-link:hover,
769
Added:
.calendar-nav-now:hover { background: var(--hover-surface); }
770
Added:
.calendar {
771
Added:
width: 100%;
772
Added:
border-collapse: collapse;
773
Added:
table-layout: fixed;
751
774
}
752
775
.calendar th {
753
776
padding: 0.25rem 0;
lib/web/handlers_logbook.ml
@@ -78,15 +78,27 @@
78
78
(* 1970-01-01 is a Thursday = 3 in Monday-first indexing. *)
79
79
((((days mod 7) + 3) mod 7) + 7) mod 7
80
80
81
Removed:
(* Build the current month's calendar, highlighting the days that carry at
82
Removed:
least one workout. [now] and each entry are read in UTC, matching how dates
83
Removed:
are shown elsewhere. *)
84
Removed:
let calendar_view ~now (entries : View_model.Logbook_entry.t list) :
85
Removed:
View_model.Calendar.t =
81
Added:
(* Build the calendar for [year]/[month], highlighting days that carry at
82
Added:
least one workout. [today] marks the current day when it falls in the shown
83
Added:
month. [years] spans the earliest entry year through the current year, so
84
Added:
the picker offers every month with history and the present. *)
85
Added:
let calendar_view ~now ~year ~month
86
Added:
(entries : View_model.Logbook_entry.t list) : View_model.Calendar.t =
86
87
let now_tm = Unix.gmtime (float_of_int now) in
87
Removed:
let year = now_tm.Unix.tm_year + 1900 in
88
Removed:
let month = now_tm.Unix.tm_mon + 1 in
89
Removed:
let today = now_tm.Unix.tm_mday in
88
Added:
let this_year = now_tm.Unix.tm_year + 1900 in
89
Added:
let today =
90
Added:
if year = this_year && month = now_tm.Unix.tm_mon + 1 then
91
Added:
now_tm.Unix.tm_mday
92
Added:
else 0
93
Added:
in
94
Added:
let entry_year e =
95
Added:
(Unix.gmtime (float_of_int e.View_model.Logbook_entry.at_unix))
96
Added:
.Unix.tm_year + 1900
97
Added:
in
98
Added:
let earliest =
99
Added:
List.fold_left (fun acc e -> min acc (entry_year e)) this_year entries
100
Added:
in
101
Added:
let years = List.init (this_year - earliest + 1) (fun i -> earliest + i) in
90
102
let workout_days =
91
103
List.filter_map
92
104
(fun (e : View_model.Logbook_entry.t) ->
@@ -99,8 +111,6 @@
99
111
let has_workout d = List.mem d workout_days in
100
112
let total = days_in_month ~year ~month in
101
113
let lead = monday_first_weekday ~year ~month ~day:1 in
102
Removed:
(* The full sequence of cells: leading blanks, the days, trailing blanks to
103
Removed:
complete the final week. *)
104
114
let cells =
105
115
List.init lead (fun _ -> View_model.Calendar.Blank)
106
116
@ List.init total (fun i ->
@@ -125,7 +135,10 @@
125
135
row :: weeks rest
126
136
in
127
137
{
128
Removed:
month_label = Printf.sprintf "%s %d" (month_name month) year;
138
Added:
selected_year = year;
139
Added:
selected_month = month;
140
Added:
months = List.init 12 (fun i -> (i + 1, month_name (i + 1)));
141
Added:
years;
129
142
weekday_headings = [ "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"; "Sun" ];
130
143
weeks = weeks cells;
131
144
}
@@ -281,12 +294,29 @@
281
294
let feedback = List.map feedback_view feedback in
282
295
(* Native prescribed records and read-only imports, interleaved by start
283
296
date, most recent first. *)
284
Removed:
let records =
297
Added:
let all_records =
285
298
List.map (entry_view log) records @ imported_entries
286
299
|> List.stable_sort (fun a b ->
287
300
Int.compare b.View_model.Logbook_entry.at_unix
288
301
a.View_model.Logbook_entry.at_unix)
289
302
in
303
Added:
let now = Recovery.timestamp_to_unix_seconds (t.now ()) in
304
Added:
let now_tm = Unix.gmtime (float_of_int now) in
305
Added:
let clamp lo hi v = max lo (min hi v) in
306
Added:
let query_int name default =
307
Added:
match Option.bind (Dream.query request name) int_of_string_opt with
308
Added:
| Some v -> v
309
Added:
| None -> default
310
Added:
in
311
Added:
let year = query_int "year" (now_tm.Unix.tm_year + 1900) in
312
Added:
let month = clamp 1 12 (query_int "month" (now_tm.Unix.tm_mon + 1)) in
313
Added:
(* Only the chosen month's entries fill the table; the calendar's year range
314
Added:
still spans all history. *)
315
Added:
let in_month (e : View_model.Logbook_entry.t) =
316
Added:
let tm = Unix.gmtime (float_of_int e.at_unix) in
317
Added:
tm.Unix.tm_year + 1900 = year && tm.Unix.tm_mon + 1 = month
318
Added:
in
319
Added:
let records = List.filter in_month all_records in
290
320
let delete_record =
291
321
match Dream.query request "delete" with
292
322
| Some id ->
@@ -310,9 +340,7 @@
310
340
| Some "start", _ | _, Some "feedback" -> true
311
341
| _ -> false
312
342
in
313
Removed:
let calendar =
314
Removed:
calendar_view ~now:(Recovery.timestamp_to_unix_seconds (t.now ())) records
315
Removed:
in
343
Added:
let calendar = calendar_view ~now ~year ~month all_records in
316
344
html
317
345
(Pages.logbook request
318
346
~logging:(Option.is_some in_progress)
test/web/logbook.ml
@@ -93,7 +93,7 @@
93
93
(* Progress now lives in the row's three-dot menu, always in the
94
94
markup — no expand round-trip. The later workout progressed, so
95
95
its line carries the progress-verdict class and the exact delta. *)
96
Removed:
let page = body (get c "/logbook") in
96
Added:
let page = body (get c "/logbook?year=1970&month=1") in
97
97
List.iter
98
98
(fun needle ->
99
99
Alcotest.(check bool)
@@ -499,7 +499,7 @@
499
499
(List.length
500
500
(Lwt_main.run
501
501
(Memory_repo.imported_records repo trainee.Trainee.id)));
502
Removed:
let page = body (get c "/logbook") in
502
Added:
let page = body (get c "/logbook?year=2024&month=1") in
503
503
Alcotest.(check bool)
504
504
"the imported workout title is shown" true
505
505
(Option.is_some (index_from ~needle:"Legs" page 0));
@@ -601,7 +601,7 @@
601
601
(List.length
602
602
(Lwt_main.run
603
603
(Memory_repo.imported_records repo trainee.Trainee.id)));
604
Removed:
let page = body (get c "/logbook") in
604
Added:
let page = body (get c "/logbook?year=2024&month=1") in
605
605
(* The later import gained 10 kg over the earlier one. *)
606
606
Alcotest.(check bool)
607
607
"the load gain since last performed is shown" true
@@ -757,10 +757,23 @@
757
757
"the calendar is present" true
758
758
(Option.is_some (index_from ~needle:"class=\"calendar\"" page 0));
759
759
Alcotest.(check bool)
760
Removed:
"the calendar names the current month" true
761
Removed:
(Option.is_some (index_from ~needle:"January 1970" page 0));
760
Added:
"a month/year picker is present" true
761
Added:
(Option.is_some (index_from ~needle:"calendar-picker" page 0));
762
762
Alcotest.(check bool)
763
Added:
"prev/next/now navigation is present" true
764
Added:
(Option.is_some (index_from ~needle:"calendar-nav" page 0));
765
Added:
Alcotest.(check bool)
763
766
"a workout day is highlighted" true
764
Removed:
(Option.is_some (index_from ~needle:"calendar-workout" page 0)) );
767
Added:
(Option.is_some (index_from ~needle:"calendar-workout" page 0));
768
Added:
(* A different month shows only that month: the January workout is
769
Added:
gone from the table, which reads as empty. *)
770
Added:
let other = body (get c "/logbook?year=1970&month=3") in
771
Added:
Alcotest.(check bool)
772
Added:
"another month's table is empty" true
773
Added:
(Option.is_some
774
Added:
(index_from ~needle:"Nothing logged yet." other 0));
775
Added:
Alcotest.(check bool)
776
Added:
"the picker still shows" true
777
Added:
(Option.is_some (index_from ~needle:"calendar-picker" other 0)) );
765
778
] );
766
779
]