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 source text 8 is never rebuilt — it 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. The calendar date is validated by a round-trip 77 through [days_from_civil], so an impossible date such as 31 Feb is rejected 78 rather than normalised. *) 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 let nonneg_int_opt s = 201 match int_of_string_opt (String.trim s) with 202 | Some i when i >= 0 -> Some i 203 | _ -> None 204 205 (* The grouping key: the exact triple that identifies a workout. *) 206 type key = string * string * string 207 208 (* One classified row, before workouts are assembled. *) 209 type row_outcome = 210 | Set of { key : key; started : int; ended : int; set : WI.source_set } 211 | Warning of WI.warning 212 213 (* Classifies one data row at 1-based source [row]. The header is row 1, so the 214 first data row is row 2. The datetime triple keys the workout; invalid or 215 reversed datetimes drop the row. A warmup is dropped with its own warning. 216 Any field the strict schema needs but the row lacks turns the row into an 217 [Unsupported_row] warning, with a concise reason, never a guessed set. *) 218 let classify_row ~utc_offset_seconds cols ~row (fields : string list) : 219 row_outcome = 220 let get = field cols fields in 221 let title = get "title" in 222 let start_time = get "start_time" in 223 let end_time = get "end_time" in 224 let exercise_title = get "exercise_title" in 225 let exercise_name = 226 if String.equal (String.trim exercise_title) "" then None 227 else Some exercise_title 228 in 229 let warn reason = 230 Warning { row; exercise_name; kind = WI.Unsupported_row reason } 231 in 232 match parse_set_type (get "set_type") with 233 | None -> warn ("unknown set type " ^ get "set_type") 234 | Some Warmup -> Warning { row; exercise_name; kind = WI.Warmup_dropped } 235 | Some (Working set_type) -> ( 236 match 237 ( parse_datetime ~utc_offset_seconds start_time, 238 parse_datetime ~utc_offset_seconds end_time ) 239 with 240 | None, _ -> warn "invalid start_time" 241 | _, None -> warn "invalid end_time" 242 | Some started, Some ended -> ( 243 if ended < started then warn "end_time precedes start_time" 244 else if String.equal (String.trim exercise_title) "" then 245 warn "missing exercise_title" 246 else 247 match parse_superset (get "superset_id") with 248 | Invalid -> warn ("invalid superset_id " ^ get "superset_id") 249 | superset_id -> ( 250 let superset_id = 251 match superset_id with 252 | Present i -> Some i 253 | Absent -> None 254 | Invalid -> None (* unreachable, handled above *) 255 in 256 match 257 ( nonneg_int_opt (get "set_index"), 258 finite_float_opt (get "weight_kg"), 259 nonneg_int_opt (get "reps") ) 260 with 261 | None, _, _ -> warn "invalid set_index" 262 | _, None, _ -> warn "missing or non-finite weight_kg" 263 | _, _, None -> warn "missing or negative reps" 264 | Some set_index, Some weight_kg, Some reps -> 265 let set : WI.source_set = 266 { 267 row; 268 exercise_name = exercise_title; 269 set_index; 270 set_type; 271 weight_kg; 272 reps; 273 superset_id; 274 } 275 in 276 Set 277 { 278 key = (title, start_time, end_time); 279 started; 280 ended; 281 set; 282 }))) 283 284 (* {1 Grouping} 285 286 Sets group into workouts by their key, in first-appearance order. A row whose 287 datetimes were valid contributes its set here; the workout keeps the first 288 [started]/[ended] it saw for that key. Warnings never group — they are 289 collected separately in source order. *) 290 291 type group = { 292 title : string; 293 started : int; 294 ended : int; 295 mutable sets_rev : WI.source_set list; 296 } 297 298 (* Folds classified rows into ordered groups and an ordered warning list. Groups 299 keep first-appearance order; within a group, sets keep source order. *) 300 let assemble outcomes = 301 let groups_rev = ref [] in 302 let table : (key, group) Hashtbl.t = Hashtbl.create 16 in 303 let warnings_rev = ref [] in 304 List.iter 305 (fun outcome -> 306 match outcome with 307 | Warning w -> warnings_rev := w :: !warnings_rev 308 | Set { key; started; ended; set } -> ( 309 match Hashtbl.find_opt table key with 310 | Some g -> g.sets_rev <- set :: g.sets_rev 311 | None -> 312 let title, _, _ = key in 313 let g = { title; started; ended; sets_rev = [ set ] } in 314 Hashtbl.add table key g; 315 groups_rev := g :: !groups_rev)) 316 outcomes; 317 (List.rev !groups_rev, List.rev !warnings_rev) 318 319 (* Builds one imported workout from a group. [make_workout] can still reject the 320 times with [Invalid_time]; the classifier already dropped reversed rows, so a 321 surviving group should not hit it, but the adapter converts any such rejection 322 into a batch warning rather than raising. *) 323 let build_workout ~batch_id ~index (g : group) : (WI.workout, WI.warning) result 324 = 325 let id = 326 WI.workout_id (WI.batch_id_to_string batch_id ^ ":w" ^ string_of_int index) 327 in 328 let sets = List.rev g.sets_rev in 329 match 330 WI.make_workout ~id ~title:g.title 331 ~started_at:(Recovery.timestamp_of_unix_seconds g.started) 332 ~ended_at:(Recovery.timestamp_of_unix_seconds g.ended) 333 ~sets 334 with 335 | Ok w -> Ok w 336 | Error _ -> 337 (* A whole group with reversed times; report at batch level. *) 338 Error 339 { 340 WI.row = 0; 341 exercise_name = None; 342 kind = WI.Unsupported_row ("workout " ^ g.title ^ " has invalid time"); 343 } 344 345 let parse ~batch_id ~fingerprint ~imported_at ~utc_offset_seconds source = 346 (* Parse the CSV text. [strip:false] keeps RFC4180 fidelity; quoted commas and 347 newlines are preserved. A malformed export raises [Csv.Failure]. *) 348 match 349 try Ok (Csv.input_all (Csv.of_string ~strip:false source)) 350 with Csv.Failure (record, field, detail) -> 351 Error (Malformed_csv { record; field; detail }) 352 with 353 | Error _ as e -> e 354 | Ok [] -> Error Empty_file 355 | Ok (header :: data_rows) -> ( 356 match resolve_columns header with 357 | Error _ as e -> e 358 | Ok cols -> 359 (* Row 1 is the header, so the first data row is row 2. *) 360 let outcomes = 361 List.mapi 362 (fun i fields -> 363 classify_row ~utc_offset_seconds cols ~row:(i + 2) fields) 364 data_rows 365 in 366 let groups, row_warnings = assemble outcomes in 367 let workouts_rev, workout_warnings_rev, _ = 368 List.fold_left 369 (fun (workouts, warnings, index) g -> 370 match build_workout ~batch_id ~index g with 371 | Ok w -> (w :: workouts, warnings, index + 1) 372 | Error warning -> (workouts, warning :: warnings, index + 1)) 373 ([], [], 1) groups 374 in 375 let workouts = List.rev workouts_rev in 376 (* Batch warnings stay in source order: the row warnings, then any 377 workout-level rejections in group order. *) 378 let warnings = row_warnings @ List.rev workout_warnings_rev in 379 Ok 380 (WI.make_batch ~id:batch_id ~source ~fingerprint ~imported_at 381 ~workouts ~warnings)) 382