1 open Dream_html 2 open Page_kit 3 open Page_shell 4 5 (* HD1-grounded self-reports, each relative to the trainee's usual baseline. *) 6 let feedback_factors = 7 [ ("motivation", "Motivation"); ("difficulty", "Perceived difficulty") ] 8 9 (* One factor: three radio buttons styled as inline buttons, none preselected. 10 The group is named by its factor, so leaving it untouched reports nothing for 11 that factor. *) 12 let feedback_level_buttons field label = 13 let choice code text = 14 tag "label" 15 [ class_ "feedback-choice" ] 16 [ 17 void "input" 18 [ 19 type_ "radio"; 20 Dream_html.string_attr "name" "%s" field; 21 Dream_html.string_attr "value" "%s" code; 22 Dream_html.string_attr "id" "%s-%s" field code; 23 ]; 24 tag "span" [] [ txt "%s" text ]; 25 ] 26 in 27 tag "div" 28 [ class_ "feedback-group" ] 29 [ 30 tag "p" [ class_ "feedback-group-label" ] [ txt "%s" label ]; 31 tag "div" 32 [ 33 class_ "feedback-buttons"; 34 Dream_html.string_attr "role" "group"; 35 Dream_html.string_attr "aria-label" "%s" label; 36 ] 37 [ 38 choice "worse" "Worse than usual"; 39 choice "usual" "As usual"; 40 choice "better" "Better than usual"; 41 ]; 42 ] 43 44 (* Every factor on one screen, one submit. A factor left unselected is simply 45 absent from the post, so a partial report needs no Skip. *) 46 let feedback_form request = 47 tag "form" 48 [ 49 action Routes.feedback; 50 post_form; 51 class_ "feedback-form"; 52 Dream_html.attr "data-hito-feedback-form"; 53 Dream_html.attr "data-hito-app-form"; 54 ] 55 [ 56 tag "fieldset" [] 57 ([ Dream_html.csrf_tag request ] 58 @ List.map 59 (fun (field, label) -> feedback_level_buttons field label) 60 feedback_factors 61 @ [ 62 tag "div" 63 [ class_ "button-group" ] 64 [ 65 tag "button" [ type_ "submit" ] [ txt "Submit feedback" ]; 66 tag "a" 67 [ 68 href Routes.logbook; 69 class_ "button secondary"; 70 Dream_html.attr "data-hito-feedback-dismiss"; 71 ] 72 [ txt "Cancel" ]; 73 ]; 74 ]); 75 ] 76 77 let feedback_modal request ~open_ = 78 tag "dialog" 79 ([ class_ "feedback-modal"; Dream_html.attr "data-hito-feedback-modal" ] 80 @ if open_ then [ Dream_html.attr "open" ] else []) 81 [ 82 tag "div" 83 [ class_ "feedback-modal-content" ] 84 [ tag "h2" [] [ txt "How are you feeling?" ]; feedback_form request ]; 85 ] 86 87 let delete_record_dialog request (record : View_model.Recorded_workout.t) = 88 tag "dialog" 89 [ class_ "confirm-dialog"; Dream_html.attr "open" ] 90 [ 91 tag "h2" [] [ txt "Delete this workout log?" ]; 92 tag "p" [] [ txt "Delete %s. This cannot be undone." record.workout_name ]; 93 tag "div" 94 [ class_ "button-group" ] 95 [ 96 tag "form" 97 [ 98 action Routes.delete_record record.id; 99 post_form; 100 class_ "delete-record-form"; 101 ] 102 [ 103 Dream_html.csrf_tag request; 104 tag "button" 105 [ type_ "submit"; class_ "danger" ] 106 [ txt "Delete workout" ]; 107 ]; 108 tag "a" 109 [ 110 href Routes.logbook; 111 class_ "button secondary"; 112 Dream_html.attr "data-hito-confirm-dismiss"; 113 ] 114 [ txt "Cancel" ]; 115 ]; 116 ] 117 118 (* An inline coloured delta for one metric: green for an increase, oxblood for a 119 decrease, following the app's progress palette. [None] when there is no prior 120 value or the value is unchanged, so no parenthetical is shown. *) 121 let duration_text ~seconds ~previous_seconds = 122 match (seconds, previous_seconds) with 123 | None, _ -> None 124 | Some seconds, None -> Some (Printf.sprintf "%d min (—)" (seconds / 60)) 125 | Some seconds, Some previous_seconds -> 126 let delta_seconds = seconds - previous_seconds in 127 let value = Printf.sprintf "%d min" (seconds / 60) in 128 let delta_minutes = float_of_int delta_seconds /. 60. in 129 Some (Printf.sprintf "%s (%+.1f min)" value delta_minutes) 130 131 let format_load load = Printf.sprintf "%g" load 132 let format_reps reps = string_of_int reps 133 134 let delta_value ~previous ~current = 135 let delta = current -. previous in 136 let class_name, value = 137 if Float.equal delta 0. then ("comparison-delta", "—") 138 else if delta > 0. then 139 ("comparison-delta delta-up", Printf.sprintf "%+g" delta) 140 else ("comparison-delta delta-down", Printf.sprintf "%+g" delta) 141 in 142 (class_name, value) 143 144 let value_cell class_name value = 145 tag "td" [ class_ "%s" class_name ] [ txt "%s" value ] 146 147 let delta_cell ~previous ~current = 148 let class_name, value = delta_value ~previous ~current in 149 tag "td" [ class_ "%s" class_name ] [ txt "%s" value ] 150 151 let comparison_rows (row : View_model.Exercise_comparison.t) = 152 let exercise_cell = 153 tag "th" 154 [ Dream_html.string_attr "scope" "row"; class_ "evidence-exercise" ] 155 [ txt "%s" row.exercise_name ] 156 in 157 [ 158 tag "tr" [] 159 [ 160 exercise_cell; 161 value_cell "observation-current" (format_load row.current_load); 162 delta_cell 163 ~previous:(Option.value ~default:row.current_load row.previous_load) 164 ~current:row.current_load; 165 value_cell "observation-current" (format_reps row.current_reps); 166 delta_cell 167 ~previous: 168 (float_of_int 169 (Option.value ~default:row.current_reps row.previous_reps)) 170 ~current:(float_of_int row.current_reps); 171 ]; 172 ] 173 174 let workout_evidence_table (entry : View_model.Recorded_workout.t) groups = 175 let caption = 176 [ 177 tag "strong" 178 [ class_ "workout-evidence-caption-name" ] 179 [ txt "%s" entry.workout_name ]; 180 tag "span" 181 [ class_ "workout-evidence-caption-status" ] 182 [ txt "Performed on %s" entry.performed_on ]; 183 ] 184 in 185 Page_kit.workout_evidence_table ~caption_class:"workout-evidence-caption" 186 ~caption 187 (List.map 188 (fun (group : View_model.Stimulus_group.t) -> 189 tag "tbody" [] (List.concat_map comparison_rows group.rows)) 190 groups) 191 192 let calendar_month_name month = 193 List.nth 194 [ 195 "January"; 196 "February"; 197 "March"; 198 "April"; 199 "May"; 200 "June"; 201 "July"; 202 "August"; 203 "September"; 204 "October"; 205 "November"; 206 "December"; 207 ] 208 (month - 1) 209 210 let workout_metadata (entry : View_model.Recorded_workout.t) = 211 let duration_item = 212 match 213 duration_text ~seconds:entry.duration_seconds 214 ~previous_seconds:entry.duration_previous_seconds 215 with 216 | None -> [] 217 | Some value -> 218 [ tag "dt" [] [ txt "Duration" ]; tag "dd" [] [ txt "%s" value ] ] 219 in 220 let next_item = 221 Option.to_list 222 (Option.map 223 (fun next -> 224 [ tag "dt" [] [ txt "Next planned" ]; tag "dd" [] [ txt "%s" next ] ]) 225 entry.next_scheduled) 226 |> List.concat 227 in 228 tag "dl" 229 [ class_ "workout-metadata" ] 230 (duration_item 231 @ [ 232 tag "dt" [] [ txt "Performed" ]; 233 tag "dd" [] [ txt "%s" entry.performed_ago ]; 234 ] 235 @ next_item) 236 237 let selected_workout_card (entry : View_model.Recorded_workout.t) = 238 let performance = 239 if entry.groups = [] then [ tag "p" [] [ txt "No exercises recorded" ] ] 240 else [ workout_evidence_table entry entry.groups ] 241 in 242 let actions = 243 if entry.imported then [] 244 else 245 [ 246 tag "div" 247 [ class_ "logbook-entry-actions" ] 248 [ 249 tag "a" 250 [ 251 href Routes.record entry.id; 252 class_ "button secondary"; 253 Dream_html.attr "data-hito-app-link"; 254 ] 255 [ txt "Edit" ]; 256 tag "a" 257 [ 258 Dream_html.string_attr "href" "/logbook?delete=%s" entry.id; 259 class_ "button outline danger"; 260 ] 261 [ txt "Delete" ]; 262 ]; 263 ] 264 in 265 let imported = 266 if entry.imported then 267 [ tag "span" [ class_ "logbook-import-pill" ] [ txt "Imported" ] ] 268 else [] 269 in 270 tag "article" 271 [ class_ "selected-workout" ] 272 (imported @ performance @ [ workout_metadata entry ] @ actions) 273 274 let selected_upcoming_card = upcoming_workout_card 275 276 let selected_date_panel (selected : View_model.Selected_date.t) = 277 let completed = List.map selected_workout_card selected.completed in 278 let planned = 279 Option.to_list (Option.map selected_upcoming_card selected.upcoming) 280 in 281 let content = 282 if completed = [] && planned = [] then 283 [ tag "p" [] [ txt "No workout was recorded or planned on this day." ] ] 284 else completed @ planned 285 in 286 tag "section" [ class_ "selected-day" ] content 287 288 (* The month calendar above the selected-day panel. Days that carry a workout 289 are highlighted; today is marked. A header row holds a previous arrow, the 290 month and year, a Today link, and a next arrow. The arrows page the query. *) 291 let calendar_grid (cal : View_model.Calendar.t) = 292 let cell = function 293 | View_model.Calendar.Blank -> tag "td" [ class_ "calendar-blank" ] [] 294 | View_model.Calendar.Day d -> 295 let classes = 296 "calendar-day" 297 ^ (if d.workout then " calendar-workout" else "") 298 ^ (if Option.is_some d.scheduled_workout then " calendar-planned" 299 else "") 300 ^ (if d.selected then " calendar-selected" else "") 301 ^ if d.today then " calendar-today" else "" 302 in 303 let aria_label = 304 match (d.workout, d.scheduled_workout, d.today) with 305 | true, Some name, true -> 306 Some 307 (Printf.sprintf "%d: completed, planned %s, today" 308 d.day_of_month name) 309 | true, Some name, false -> 310 Some 311 (Printf.sprintf "%d: completed, planned %s" d.day_of_month name) 312 | true, None, true -> 313 Some 314 (Printf.sprintf "%d: completed workout, today" d.day_of_month) 315 | true, None, false -> 316 Some (Printf.sprintf "%d: completed workout" d.day_of_month) 317 | false, Some name, true -> 318 Some (Printf.sprintf "%d: planned %s, today" d.day_of_month name) 319 | false, Some name, false -> 320 Some (Printf.sprintf "%d: planned %s" d.day_of_month name) 321 | false, None, true -> 322 Some (Printf.sprintf "%d: today" d.day_of_month) 323 | false, None, false -> None 324 in 325 let title = 326 Option.map 327 (fun name -> Printf.sprintf "Planned: %s" name) 328 d.scheduled_workout 329 in 330 let href = 331 Printf.sprintf "/logbook?year=%d&month=%d&day=%d" cal.selected_year 332 cal.selected_month d.day_of_month 333 in 334 tag "td" 335 ([ Dream_html.string_attr "class" "%s" classes ] 336 @ Option.to_list 337 (Option.map (Dream_html.string_attr "aria-label" "%s") aria_label) 338 @ Option.to_list 339 (Option.map (Dream_html.string_attr "title" "%s") title)) 340 [ 341 tag "a" 342 [ 343 Dream_html.string_attr "href" "%s" href; 344 class_ "calendar-day-link"; 345 Dream_html.attr "data-hito-app-link"; 346 Dream_html.string_attr "aria-label" "Select day %d" 347 d.day_of_month; 348 ] 349 [ txt "%d" d.day_of_month ]; 350 ] 351 in 352 let prev_month = 353 if cal.selected_month = 1 then (cal.selected_year - 1, 12) 354 else (cal.selected_year, cal.selected_month - 1) 355 in 356 let next_month = 357 if cal.selected_month = 12 then (cal.selected_year + 1, 1) 358 else (cal.selected_year, cal.selected_month + 1) 359 in 360 let arrow ~label (y, m) rel = 361 tag "a" 362 [ 363 Dream_html.string_attr "href" "/logbook?year=%d&month=%d" y m; 364 class_ "calendar-arrow"; 365 Dream_html.attr "data-hito-app-link"; 366 Dream_html.string_attr "aria-label" "%s" rel; 367 ] 368 [ txt "%s" label ] 369 in 370 (* Header: previous, the month and year, a Today link that returns to the 371 current month, next. *) 372 tag "section" 373 [ 374 class_ "logbook-calendar"; 375 Dream_html.string_attr "aria-labelledby" "calendar-heading"; 376 ] 377 [ 378 tag "h2" [ id "calendar-heading"; class_ "sr-only" ] [ txt "Calendar" ]; 379 tag "div" 380 [ class_ "calendar" ] 381 [ 382 tag "nav" 383 [ 384 class_ "calendar-header"; 385 Dream_html.string_attr "aria-label" "Calendar navigation"; 386 ] 387 [ 388 arrow ~label:"‹" prev_month "Previous month"; 389 tag "span" 390 [ class_ "calendar-month" ] 391 [ 392 txt "%s %d" 393 (calendar_month_name cal.selected_month) 394 cal.selected_year; 395 ]; 396 tag "a" 397 [ 398 href Routes.logbook; 399 class_ "calendar-today-link"; 400 Dream_html.attr "data-hito-app-link"; 401 ] 402 [ txt "Today" ]; 403 arrow ~label:"›" next_month "Next month"; 404 ]; 405 tag "table" 406 [ class_ "calendar-grid" ] 407 [ 408 tag "thead" [] 409 [ 410 tag "tr" [] 411 (List.map 412 (fun h -> 413 tag "th" 414 [ Dream_html.string_attr "scope" "col" ] 415 [ txt "%s" h ]) 416 cal.weekday_headings); 417 ]; 418 tag "tbody" [] 419 (List.map 420 (fun week -> tag "tr" [] (List.map cell week)) 421 cal.weeks); 422 ]; 423 tag "div" 424 [ 425 class_ "calendar-legend"; 426 Dream_html.string_attr "role" "group"; 427 Dream_html.string_attr "aria-label" "Calendar key"; 428 ] 429 [ 430 tag "span" 431 [ class_ "calendar-legend-item" ] 432 [ 433 tag "span" 434 [ class_ "calendar-legend-swatch calendar-legend-workout" ] 435 []; 436 txt "Completed"; 437 ]; 438 tag "span" 439 [ class_ "calendar-legend-item" ] 440 [ 441 tag "span" 442 [ class_ "calendar-legend-swatch calendar-legend-planned" ] 443 []; 444 txt "Planned"; 445 ]; 446 tag "span" 447 [ class_ "calendar-legend-item" ] 448 [ 449 tag "span" 450 [ class_ "calendar-legend-swatch calendar-legend-today" ] 451 []; 452 txt "Today"; 453 ]; 454 ]; 455 tag "p" 456 [ class_ "calendar-note" ] 457 [ 458 txt 459 "Planned dates follow the recovery time in your routine. Hover \ 460 a planned day to see the workout."; 461 ]; 462 ]; 463 ] 464 465 let logbook_tabs ~active_tab = 466 link_tabs ~aria_label:"Logbook views" ~active:active_tab 467 [ 468 ("calendar", "Calendar", "/logbook?tab=calendar"); 469 ("progress", "Progress", "/logbook?tab=progress"); 470 ] 471 472 let progress_legend () = 473 tag "div" 474 [ class_ "chart-legend" ] 475 [ 476 tag "span" 477 [ class_ "chart-legend-item weight" ] 478 [ txt "Weight (kg), left axis" ]; 479 tag "span" [ class_ "chart-legend-item reps" ] [ txt "Reps, right axis" ]; 480 ] 481 482 let progress_chart_section (chart : View_model.Progress_page.chart) = 483 tag "section" 484 [ class_ "progress-chart-section" ] 485 [ 486 tag "h2" [] [ txt "%s" chart.exercise_name ]; 487 progress_legend (); 488 Svg_chart.render chart; 489 ] 490 491 let progress_content charts = 492 match charts with 493 | [] -> 494 [ 495 tag "p" [] 496 [ 497 txt 498 "No exercise has enough history to chart yet. Log or import at \ 499 least two performances of an exercise to see its progress."; 500 ]; 501 ] 502 | charts -> List.map progress_chart_section charts 503 504 let logbook request ?workout_started ~viewer ?calendar ?selected_date 505 ?(suggest_feedback = false) ?(feedback_open = false) ?delete_record 506 ?(tab = "calendar") ?progress_charts () = 507 let active_tab = 508 if String.equal tab "progress" then "progress" else "calendar" 509 in 510 let content = 511 match active_tab with 512 | "calendar" -> 513 (match calendar with Some cal -> [ calendar_grid cal ] | None -> []) 514 @ [ 515 (match selected_date with 516 | Some selected -> selected_date_panel selected 517 | None -> 518 tag "section" 519 [ class_ "selected-day empty-selected-day" ] 520 [ tag "p" [] [ txt "Select a day to view its workout." ] ]); 521 ] 522 | "progress" -> Option.value progress_charts ~default:[] |> progress_content 523 | _ -> [] 524 in 525 html_page ~viewer ~request ~active:"logbook" ?workout_started "Logbook" 526 ([ 527 logbook_tabs ~active_tab; 528 (if suggest_feedback then 529 tag "p" 530 [ class_ "eyebrow" ] 531 [ txt "Workout saved — add feedback while it is fresh." ] 532 else txt ""); 533 ] 534 @ content 535 @ [ feedback_modal request ~open_:feedback_open ] 536 @ 537 match delete_record with 538 | Some record -> [ delete_record_dialog request record ] 539 | None -> []) 540