1 (** See {!module:Hevy_csv} for the contract. 2 3 The parse runs in two stages. First it maps the header to column indices, 4 failing early on a missing column. Then it walks the data rows once: each 5 row becomes a set for some workout, or a batch warning. Rows group into 6 workouts by their exact [(title, start_time, end_time)] triple in 7 first-appearance order, and warnings stay in source order. The adapter never 8 rebuilds the source text. The text flows verbatim into the batch. *) 9 10 open Hito_app 11 module WI = Workout_import 12 13 type error = 14 | Malformed_csv of { record : int; field : int; detail : string } 15 | Missing_column of string 16 | Empty_file 17 18 let pp_error ppf = function 19 | Malformed_csv { record; field; detail } -> 20 Format.fprintf ppf "malformed CSV at record %d, field %d: %s" record field 21 detail 22 | Missing_column name -> Format.fprintf ppf "missing column %S" name 23 | Empty_file -> Format.pp_print_string ppf "empty file" 24 25 (* The strict native schema. Every column must be present. The order here is 26 canonical: a missing-column error names the first absent column in this 27 order, not the order the header happens to use. *) 28 let canonical_columns = 29 [ 30 "title"; 31 "start_time"; 32 "end_time"; 33 "description"; 34 "exercise_title"; 35 "superset_id"; 36 "exercise_notes"; 37 "set_index"; 38 "set_type"; 39 "weight_kg"; 40 "reps"; 41 "distance_km"; 42 "duration_seconds"; 43 "rpe"; 44 ] 45 46 (* Column indices resolved from the header, keyed by canonical name. Built once, 47 then read for every row. *) 48 type columns = (string * int) list 49 50 (* Maps the header row to column indices. The header order may vary, so each 51 name is looked up by value. The first canonical column absent from the header 52 fails the whole parse. *) 53 let resolve_columns (header : string list) : (columns, error) result = 54 let indexed = List.mapi (fun i name -> (name, i)) header in 55 let rec go acc = function 56 | [] -> Ok (List.rev acc) 57 | name :: rest -> ( 58 match List.assoc_opt name indexed with 59 | Some i -> go ((name, i) :: acc) rest 60 | None -> Error (Missing_column name)) 61 in 62 go [] canonical_columns 63 64 (* A row is a plain string list. This reads one column by canonical name, 65 returning [""] for a short row rather than raising. The column is guaranteed 66 present in [cols] once [resolve_columns] succeeds. *) 67 let field (cols : columns) (row : string list) name = 68 match List.assoc_opt name cols with 69 | None -> "" 70 | Some i -> ( match List.nth_opt row i with Some v -> v | None -> "") 71 72 (* {1 Datetime} 73 74 Hevy writes local wall time as [DD Mon YYYY, HH:MM] with an English month 75 abbreviation. The adapter converts to UTC seconds using the caller's fixed 76 offset: UTC = civil - offset. A round-trip through [days_from_civil] 77 validates the calendar date, so the adapter rejects an impossible date such 78 as 31 Feb rather than normalising it. *) 79 80 let months = 81 [| 82 "Jan"; 83 "Feb"; 84 "Mar"; 85 "Apr"; 86 "May"; 87 "Jun"; 88 "Jul"; 89 "Aug"; 90 "Sep"; 91 "Oct"; 92 "Nov"; 93 "Dec"; 94 |] 95 96 let month_index abbrev = 97 let rec go i = 98 if i >= Array.length months then None 99 else if String.equal months.(i) abbrev then Some (i + 1) 100 else go (i + 1) 101 in 102 go 0 103 104 (* Days from the civil date 1970-01-01 to [y]-[m]-[d]. Howard Hinnant's 105 algorithm, valid for the proleptic Gregorian calendar. Used both to compute 106 the timestamp and, by round-trip, to confirm the date is real. *) 107 let days_from_civil y m d = 108 let y = if m <= 2 then y - 1 else y in 109 let era = (if y >= 0 then y else y - 399) / 400 in 110 let yoe = y - (era * 400) in 111 let doy = (((153 * if m > 2 then m - 3 else m + 9) + 2) / 5) + d - 1 in 112 let doe = (yoe * 365) + (yoe / 4) - (yoe / 100) + doy in 113 (era * 146097) + doe - 719468 114 115 (* The inverse of [days_from_civil], for the round-trip check. *) 116 let civil_from_days z = 117 let z = z + 719468 in 118 let era = (if z >= 0 then z else z - 146096) / 146097 in 119 let doe = z - (era * 146097) in 120 let yoe = (doe - (doe / 1460) + (doe / 36524) - (doe / 146096)) / 365 in 121 let y = yoe + (era * 400) in 122 let doy = doe - ((365 * yoe) + (yoe / 4) - (yoe / 100)) in 123 let mp = ((5 * doy) + 2) / 153 in 124 let d = doy - (((153 * mp) + 2) / 5) + 1 in 125 let m = if mp < 10 then mp + 3 else mp - 9 in 126 ((if m <= 2 then y + 1 else y), m, d) 127 128 let is_digits s = 129 String.length s > 0 && String.for_all (fun c -> c >= '0' && c <= '9') s 130 131 (* Parses one Hevy datetime to UTC seconds at the given offset. Returns [None] 132 on any deviation from the exact [DD Mon YYYY, HH:MM] shape, an unknown month, 133 or a date that fails the calendar round-trip. *) 134 let parse_datetime ~utc_offset_seconds s = 135 match String.split_on_char ',' s with 136 | [ date_part; time_part ] -> ( 137 let date_fields = String.split_on_char ' ' (String.trim date_part) in 138 let time_fields = String.split_on_char ':' (String.trim time_part) in 139 match (date_fields, time_fields) with 140 | [ dd; mon; yyyy ], [ hh; mm ] 141 when is_digits dd && is_digits yyyy && is_digits hh && is_digits mm -> ( 142 match month_index mon with 143 | None -> None 144 | Some month -> 145 let day = int_of_string dd in 146 let year = int_of_string yyyy in 147 let hour = int_of_string hh in 148 let minute = int_of_string mm in 149 if 150 day < 1 || day > 31 || hour > 23 || minute > 59 151 || String.length yyyy <> 4 152 then None 153 else 154 let days = days_from_civil year month day in 155 (* Reject impossible calendar dates by round-trip. *) 156 if civil_from_days days <> (year, month, day) then None 157 else 158 let civil_seconds = 159 (days * 86_400) + (hour * 3_600) + (minute * 60) 160 in 161 Some (civil_seconds - utc_offset_seconds)) 162 | _ -> None) 163 | _ -> None 164 165 (* {1 Set types} *) 166 167 (* Hevy set types the adapter understands. [Warmup] never reaches a set: it 168 becomes a [Warmup_dropped] warning. Any other value is an unsupported row. *) 169 type parsed_set_type = Warmup | Working of WI.source_set_type 170 171 let parse_set_type s = 172 match String.lowercase_ascii (String.trim s) with 173 | "warmup" -> Some Warmup 174 | "normal" -> Some (Working WI.Normal) 175 | "failure" -> Some (Working WI.Failure) 176 | "dropset" -> Some (Working WI.Dropset) 177 | _ -> None 178 179 (* {1 Row outcome} 180 181 Each data row resolves to exactly one of: a set belonging to a workout keyed 182 by its datetime triple, a warning, or — when the datetimes are invalid and 183 the row cannot be grouped — a batch-level warning with no workout. *) 184 185 (* A parsed superset id: absent, present, or malformed. *) 186 type superset = Absent | Present of int | Invalid 187 188 let parse_superset s = 189 let s = String.trim s in 190 if String.equal s "" then Absent 191 else match int_of_string_opt s with Some i -> Present i | None -> Invalid 192 193 (* A finite float, rejecting NaN and the infinities that [float_of_string] 194 otherwise accepts. *) 195 let finite_float_opt s = 196 match float_of_string_opt (String.trim s) with 197 | Some f when Float.is_finite f -> Some f 198 | _ -> None 199 200 (* A load: finite and nonnegative. Zero is a bodyweight movement. This is the 201 rule {!Evidence.Stimulus.Effort.make} enforces, applied at the trust 202 boundary so a bad row becomes a warning, never a rejected effort later. *) 203 let load_opt s = 204 match finite_float_opt s with Some f when f >= 0. -> Some f | _ -> None 205 206 let nonneg_int_opt s = 207 match int_of_string_opt (String.trim s) with 208 | Some i when i >= 0 -> Some i 209 | _ -> None 210 211 (* A rep count: at least one. A set taken to failure has at least one rep, 212 which is the rule {!Evidence.Stimulus.Effort.make} enforces. *) 213 let reps_opt s = 214 match int_of_string_opt (String.trim s) with 215 | Some i when i >= 1 -> Some i 216 | _ -> None 217 218 (* The grouping key: the exact triple that identifies a workout. *) 219 type key = string * string * string 220 221 (* One classified row, before workouts are assembled. *) 222 type row_outcome = 223 | Set of { key : key; started : int; ended : int; set : WI.source_set } 224 | Warning of WI.warning 225 226 (* Classifies one data row at 1-based source [row]. The header is row 1, so the 227 first data row is row 2. The datetime triple keys the workout; invalid or 228 reversed datetimes drop the row. A warmup is dropped with its own warning. 229 Any field the strict schema needs but the row lacks turns the row into an 230 [Unsupported_row] warning, with a concise reason, never a guessed set. *) 231 let classify_row ~utc_offset_seconds cols ~row (fields : string list) : 232 row_outcome = 233 let get = field cols fields in 234 let title = get "title" in 235 let start_time = get "start_time" in 236 let end_time = get "end_time" in 237 let exercise_title = get "exercise_title" in 238 let exercise_name = 239 if String.equal (String.trim exercise_title) "" then None 240 else Some exercise_title 241 in 242 let warn reason = 243 Warning { row; exercise_name; kind = WI.Unsupported_row reason } 244 in 245 match parse_set_type (get "set_type") with 246 | None -> warn ("unknown set type " ^ get "set_type") 247 | Some Warmup -> Warning { row; exercise_name; kind = WI.Warmup_dropped } 248 | Some (Working set_type) -> ( 249 match 250 ( parse_datetime ~utc_offset_seconds start_time, 251 parse_datetime ~utc_offset_seconds end_time ) 252 with 253 | None, _ -> warn "invalid start_time" 254 | _, None -> warn "invalid end_time" 255 | Some started, Some ended -> ( 256 if ended < started then warn "end_time precedes start_time" 257 else if String.equal (String.trim exercise_title) "" then 258 warn "missing exercise_title" 259 else 260 match parse_superset (get "superset_id") with 261 | Invalid -> warn ("invalid superset_id " ^ get "superset_id") 262 | superset_id -> ( 263 let superset_id = 264 match superset_id with 265 | Present i -> Some i 266 | Absent -> None 267 | Invalid -> None (* unreachable, handled above *) 268 in 269 match 270 ( nonneg_int_opt (get "set_index"), 271 load_opt (get "weight_kg"), 272 reps_opt (get "reps") ) 273 with 274 | None, _, _ -> warn "invalid set_index" 275 | _, None, _ -> 276 warn "missing, negative, or non-finite weight_kg" 277 | _, _, None -> warn "missing reps or fewer than one" 278 | Some set_index, Some weight_kg, Some reps -> 279 let set : WI.source_set = 280 { 281 row; 282 exercise_name = exercise_title; 283 set_index; 284 set_type; 285 weight_kg; 286 reps; 287 superset_id; 288 } 289 in 290 Set 291 { 292 key = (title, start_time, end_time); 293 started; 294 ended; 295 set; 296 }))) 297 298 (* {1 Grouping} 299 300 Sets group into workouts by their key, in first-appearance order. A row whose 301 datetimes were valid contributes its set here; the workout keeps the first 302 [started]/[ended] it saw for that key. Warnings never group — they are 303 collected separately in source order. *) 304 305 type group = { 306 title : string; 307 started : int; 308 ended : int; 309 mutable sets_rev : WI.source_set list; 310 } 311 312 (* Folds classified rows into ordered groups and an ordered warning list. Groups 313 keep first-appearance order; within a group, sets keep source order. *) 314 let assemble outcomes = 315 let groups_rev = ref [] in 316 let table : (key, group) Hashtbl.t = Hashtbl.create 16 in 317 let warnings_rev = ref [] in 318 List.iter 319 (fun outcome -> 320 match outcome with 321 | Warning w -> warnings_rev := w :: !warnings_rev 322 | Set { key; started; ended; set } -> ( 323 match Hashtbl.find_opt table key with 324 | Some g -> g.sets_rev <- set :: g.sets_rev 325 | None -> 326 let title, _, _ = key in 327 let g = { title; started; ended; sets_rev = [ set ] } in 328 Hashtbl.add table key g; 329 groups_rev := g :: !groups_rev)) 330 outcomes; 331 (List.rev !groups_rev, List.rev !warnings_rev) 332 333 (* Builds one imported workout from a group. [make_workout] can still reject the 334 times with [Invalid_time]. The classifier already dropped reversed rows, so a 335 surviving group should not reach that rejection. The adapter still converts 336 any such rejection into a batch warning rather than raising. *) 337 let build_workout ~batch_id ~index (g : group) : (WI.workout, WI.warning) result 338 = 339 let id = 340 WI.workout_id (WI.batch_id_to_string batch_id ^ ":w" ^ string_of_int index) 341 in 342 let sets = List.rev g.sets_rev in 343 match 344 WI.make_workout ~id ~title:g.title 345 ~started_at:(Recovery.timestamp_of_unix_seconds g.started) 346 ~ended_at:(Recovery.timestamp_of_unix_seconds g.ended) 347 ~sets 348 with 349 | Ok w -> Ok w 350 | Error _ -> 351 (* A whole group with reversed times; report at batch level. *) 352 Error 353 { 354 WI.row = 0; 355 exercise_name = None; 356 kind = WI.Unsupported_row ("workout " ^ g.title ^ " has invalid time"); 357 } 358 359 let parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source = 360 (* Parse the CSV text. [strip:false] keeps RFC4180 fidelity. It preserves 361 quoted commas and newlines. A malformed export raises [Csv.Failure]. *) 362 match 363 try Ok (Csv.input_all (Csv.of_string ~strip:false source)) 364 with Csv.Failure (record, field, detail) -> 365 Error (Malformed_csv { record; field; detail }) 366 with 367 | Error _ as e -> e 368 | Ok [] -> Error Empty_file 369 | Ok (header :: data_rows) -> ( 370 match resolve_columns header with 371 | Error _ as e -> e 372 | Ok cols -> 373 (* Row 1 is the header, so the first data row is row 2. *) 374 let outcomes = 375 List.mapi 376 (fun i fields -> 377 classify_row ~utc_offset_seconds cols ~row:(i + 2) fields) 378 data_rows 379 in 380 let groups, row_warnings = assemble outcomes in 381 let workouts_rev, workout_warnings_rev, _ = 382 List.fold_left 383 (fun (workouts, warnings, index) g -> 384 match build_workout ~batch_id ~index g with 385 | Ok w -> (w :: workouts, warnings, index + 1) 386 | Error warning -> (workouts, warning :: warnings, index + 1)) 387 ([], [], 1) groups 388 in 389 let workouts = List.rev workouts_rev in 390 (* Batch warnings stay in source order: the row warnings, then any 391 workout-level rejections in group order. *) 392 let warnings = row_warnings @ List.rev workout_warnings_rev in 393 Ok 394 (WI.make_batch ~id:batch_id ~source ~fingerprint ~imported_at 395 ~workouts ~warnings)) 396