1 type error = 2 | Malformed of string 3 | Unknown_exercise of string 4 | Unknown_routine of string 5 | Unknown_workout_name of { routine : string; workout : string } 6 | Replay_rejected of string 7 8 let pp_error ppf = function 9 | Malformed detail -> Format.fprintf ppf "malformed record: %s" detail 10 | Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id 11 | Unknown_routine name -> Format.fprintf ppf "unknown routine %S" name 12 | Unknown_workout_name { routine; workout } -> 13 Format.fprintf ppf "routine %S has no workout %S" routine workout 14 | Replay_rejected detail -> 15 Format.fprintf ppf "stored record rejected: %s" detail 16 17 (* --- extension and outcome codes --- *) 18 19 let extension_code : Evidence.Stimulus.extension -> string = function 20 | Forced_reps -> "forced" 21 | Negatives -> "negatives" 22 | Rest_pause -> "rest-pause" 23 | Static_hold -> "static" 24 25 let extension_of_code = function 26 | "forced" -> Ok Evidence.Stimulus.Forced_reps 27 | "negatives" -> Ok Evidence.Stimulus.Negatives 28 | "rest-pause" -> Ok Evidence.Stimulus.Rest_pause 29 | "static" -> Ok Evidence.Stimulus.Static_hold 30 | other -> Error (Malformed (Printf.sprintf "extension %S" other)) 31 32 let encode_outcome (outcome : Evidence.Stimulus.outcome) = 33 match outcome with 34 | Positive_failure -> "positive" 35 | Beyond_failure (first, rest) -> 36 "beyond:" ^ String.concat "," (List.map extension_code (first :: rest)) 37 38 let decode_outcome text = 39 if String.equal text "positive" then Ok Evidence.Stimulus.Positive_failure 40 else 41 match String.split_on_char ':' text with 42 | [ "beyond"; codes ] -> ( 43 match String.split_on_char ',' codes with 44 | [] | [ "" ] -> Error (Malformed "empty beyond-failure") 45 | first :: rest -> 46 let ( let* ) = Result.bind in 47 let* first = extension_of_code first in 48 let rec go acc = function 49 | [] -> Ok (List.rev acc) 50 | code :: tl -> ( 51 match extension_of_code code with 52 | Ok e -> go (e :: acc) tl 53 | Error _ as e -> e) 54 in 55 let* rest = go [] rest in 56 Ok (Evidence.Stimulus.Beyond_failure (first, rest))) 57 | _ -> Error (Malformed (Printf.sprintf "outcome %S" text)) 58 59 (* --- efforts and stimuli --- *) 60 61 let encode_effort effort = 62 let exercise = Evidence.Stimulus.Effort.exercise effort in 63 Printf.sprintf "%s\t%h\t%d\t%s" 64 (Exercise.id exercise :> string) 65 (Evidence.Stimulus.Effort.load effort) 66 (Evidence.Stimulus.Effort.reps effort) 67 (encode_outcome (Evidence.Stimulus.Effort.outcome effort)) 68 69 let encode_stimulus ~slot stimulus = 70 match Evidence.Stimulus.delivery stimulus with 71 | Evidence.Stimulus.Single effort -> 72 Printf.sprintf "stimulus\t%d\tsingle\t%s" slot (encode_effort effort) 73 | Evidence.Stimulus.Pair { first; second } -> 74 Printf.sprintf "stimulus\t%d\tpair\t%s\t%s" slot (encode_effort first) 75 (encode_effort second) 76 77 let ( let* ) = Result.bind 78 79 let decode_effort = function 80 | [ exid; load; reps; outcome ] -> ( 81 match Exercise.find_id exid with 82 | None -> Error (Unknown_exercise exid) 83 | Some exercise -> ( 84 match (float_of_string_opt load, int_of_string_opt reps) with 85 | Some load, Some reps -> 86 let* outcome = decode_outcome outcome in 87 Ok (Evidence.Stimulus.Effort.make ~exercise ~load ~reps ~outcome) 88 | _ -> Error (Malformed "effort load/reps"))) 89 | _ -> Error (Malformed "effort arity") 90 91 (* Decode a stimulus and the slot it filled. The current format prefixes the 92 slot; a record from before slots were stored omits it, and replays in 93 performance order through [add_stimulus] instead. *) 94 let decode_stimulus fields = 95 let delivery = function 96 | "single" :: rest -> 97 let* effort = decode_effort rest in 98 Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort)) 99 | "pair" :: rest -> ( 100 match rest with 101 | [ a; b; c; d; e; f; g; h ] -> 102 let* first = decode_effort [ a; b; c; d ] in 103 let* second = decode_effort [ e; f; g; h ] in 104 Ok 105 (Evidence.Stimulus.make 106 (Evidence.Stimulus.Pair { first; second })) 107 | _ -> Error (Malformed "pair arity")) 108 | _ -> Error (Malformed "stimulus delivery") 109 in 110 match fields with 111 | slot :: rest when Option.is_some (int_of_string_opt slot) -> 112 let* stimulus = delivery rest in 113 Ok (Some (Option.get (int_of_string_opt slot)), stimulus) 114 | rest -> 115 let* stimulus = delivery rest in 116 Ok (None, stimulus) 117 118 (* --- clearance --- *) 119 120 let encode_clearance clearance = 121 match Recovery.basis clearance with 122 | Recovery.Recovered -> "clearance\trecovered" 123 | Recovery.Overridden { rested; recommended } -> 124 Printf.sprintf "clearance\toverridden\t%d\t%d" 125 (Recovery.duration_to_seconds rested) 126 (Recovery.duration_to_seconds recommended) 127 128 (* Recovery exposes only hours/days constructors, so derive an arbitrary 129 second-valued duration through elapsed: since=0, now=secs yields exactly 130 [secs] seconds. *) 131 let seconds_duration secs = 132 Recovery.elapsed 133 ~since:(Recovery.timestamp_of_unix_seconds 0) 134 ~now:(Recovery.timestamp_of_unix_seconds secs) 135 136 (* A clearance cannot be minted directly; it is derived from a readiness. 137 [Recovered] comes from a [Ready] reading; an override needs a [Recovering] 138 reading carrying the stored durations. *) 139 let decode_clearance = function 140 | [ "recovered" ] -> Ok (Option.get (Recovery.clear Recovery.Ready)) 141 | [ "overridden"; rested; recommended ] -> ( 142 match (int_of_string_opt rested, int_of_string_opt recommended) with 143 | Some rested, Some recommended -> 144 Ok 145 (Recovery.override 146 (Recovery.Recovering 147 { 148 rested = seconds_duration rested; 149 recommended = seconds_duration recommended; 150 })) 151 | _ -> Error (Malformed "clearance durations")) 152 | _ -> Error (Malformed "clearance basis") 153 154 (* --- workout --- *) 155 156 let encode_workout ~routine_name workout = 157 let buf = Buffer.create 256 in 158 let line s = 159 Buffer.add_string buf s; 160 Buffer.add_char buf '\n' 161 in 162 line (Printf.sprintf "routine\t%s" routine_name); 163 line 164 (Printf.sprintf "prescription\t%s" 165 (Prescription.Workout.name (Evidence.Workout.prescription workout))); 166 line (encode_clearance (Evidence.Workout.clearance workout)); 167 line 168 (Printf.sprintf "started\t%s" 169 (Timestamp.encode (Evidence.Workout.started_at workout))); 170 (match Evidence.Workout.ended_at workout with 171 | Some ended -> line (Printf.sprintf "ended\t%s" (Timestamp.encode ended)) 172 | None -> ()); 173 List.iter 174 (fun (slot, stimulus) -> line (encode_stimulus ~slot stimulus)) 175 (Evidence.Workout.performed workout); 176 Buffer.contents buf 177 178 (* A fully-parsed header, gathered before any replay. Parsing produces this 179 typed record; replay consumes it. Keeping the two phases apart removes the 180 mutable accumulators the old single pass needed. *) 181 type parsed = { 182 routine_name : string; 183 prescription_name : string; 184 clearance : Recovery.clearance; 185 started_at : Recovery.timestamp; 186 ended_at : Recovery.timestamp option; 187 stimuli : (int option * Evidence.Stimulus.t) list; 188 (** Performance order, each with the slot it filled when known. *) 189 } 190 191 (* Fields accumulated while folding over lines; every field is optional until 192 its line is seen. [stimuli] is reversed for O(1) prepend and flipped once at 193 the end. *) 194 type acc = { 195 a_routine : string option; 196 a_prescription : string option; 197 a_clearance : Recovery.clearance option; 198 a_started : Recovery.timestamp option; 199 a_ended : Recovery.timestamp option; 200 a_stimuli_rev : (int option * Evidence.Stimulus.t) list; 201 } 202 203 let empty_acc = 204 { 205 a_routine = None; 206 a_prescription = None; 207 a_clearance = None; 208 a_started = None; 209 a_ended = None; 210 a_stimuli_rev = []; 211 } 212 213 let parse_timestamp label text = 214 match Timestamp.decode text with 215 | Ok timestamp -> Ok timestamp 216 | Error _ -> Error (Malformed label) 217 218 (* Fold one line into the accumulator. A line either sets a header field or 219 appends a stimulus; anything else is malformed. *) 220 let step acc = function 221 | [ "routine"; name ] -> Ok { acc with a_routine = Some name } 222 | [ "prescription"; name ] -> Ok { acc with a_prescription = Some name } 223 | "clearance" :: rest -> 224 let* c = decode_clearance rest in 225 Ok { acc with a_clearance = Some c } 226 | [ "started"; text ] -> 227 let* timestamp = parse_timestamp "started timestamp" text in 228 Ok { acc with a_started = Some timestamp } 229 | [ "ended"; text ] -> 230 let* timestamp = parse_timestamp "ended timestamp" text in 231 Ok { acc with a_ended = Some timestamp } 232 | "stimulus" :: rest -> 233 let* s = decode_stimulus rest in 234 Ok { acc with a_stimuli_rev = s :: acc.a_stimuli_rev } 235 | fields -> Error (Malformed (String.concat "|" fields)) 236 237 (* Parse the whole text into a typed header, or fail. Mandatory fields are 238 checked here so replay never sees a partial record. *) 239 let parse text = 240 let lines = 241 String.split_on_char '\n' text 242 |> List.filter (fun l -> String.length l > 0) 243 |> List.map (fun l -> String.split_on_char '\t' l) 244 in 245 let rec fold acc = function 246 | [] -> Ok acc 247 | line :: tl -> 248 let* acc = step acc line in 249 fold acc tl 250 in 251 let* acc = fold empty_acc lines in 252 match (acc.a_routine, acc.a_prescription, acc.a_clearance, acc.a_started) with 253 | Some routine_name, Some prescription_name, Some clearance, Some started_at 254 -> 255 Ok 256 { 257 routine_name; 258 prescription_name; 259 clearance; 260 started_at; 261 ended_at = acc.a_ended; 262 stimuli = List.rev acc.a_stimuli_rev; 263 } 264 | _ -> Error (Malformed "missing header fields") 265 266 (* Resolve the prescription named in the header against the catalog. *) 267 let resolve_prescription ~find_routine parsed = 268 match find_routine parsed.routine_name with 269 | None -> Error (Unknown_routine parsed.routine_name) 270 | Some routine -> ( 271 match 272 List.find_opt 273 (fun w -> 274 String.equal (Prescription.Workout.name w) parsed.prescription_name) 275 (Prescription.Routine.workouts routine) 276 with 277 | Some prescription -> Ok prescription 278 | None -> 279 Error 280 (Unknown_workout_name 281 { 282 routine = parsed.routine_name; 283 workout = parsed.prescription_name; 284 })) 285 286 (* Drive the core constructors from a typed header. The core raises on a 287 rejected stimulus; catch it once here and report it as data corruption. *) 288 let replay ~prescription parsed = 289 try 290 let workout = 291 Evidence.Workout.start prescription ~clearance:parsed.clearance 292 ~started_at:parsed.started_at 293 in 294 let workout = 295 List.fold_left 296 (fun workout (slot, stimulus) -> 297 match slot with 298 | Some slot -> Evidence.Workout.record_at workout ~slot stimulus 299 | None -> Evidence.Workout.add_stimulus workout stimulus) 300 workout parsed.stimuli 301 in 302 let workout = 303 match parsed.ended_at with 304 | Some ended_at -> Evidence.Workout.finish workout ~ended_at 305 | None -> workout 306 in 307 Ok workout 308 with Evidence.Workout.Invalid err -> 309 Error (Replay_rejected (Format.asprintf "%a" Evidence.Workout.pp_error err)) 310 311 let decode_workout ~find_routine text = 312 let* parsed = parse text in 313 let* prescription = resolve_prescription ~find_routine parsed in 314 replay ~prescription parsed 315 316 (* --- subjective feedback --- *) 317 318 let level_code (l : Evidence.Feedback.level) = 319 string_of_int (Evidence.Feedback.level_to_score l) 320 321 let level_of_code code = 322 match int_of_string_opt code with 323 | Some n -> ( 324 match Evidence.Feedback.level_of_score n with 325 | Some l -> Ok l 326 | None -> Error (Malformed (Printf.sprintf "level %S" code))) 327 | None -> Error (Malformed (Printf.sprintf "level %S" code)) 328 329 let signal_code : Evidence.Feedback.signal -> string = function 330 | Sleep l -> "sleep:" ^ level_code l 331 | Appetite l -> "appetite:" ^ level_code l 332 | Readiness l -> "readiness:" ^ level_code l 333 | Motivation l -> "motivation:" ^ level_code l 334 | Difficulty l -> "difficulty:" ^ level_code l 335 | Pain -> "pain" 336 | Injury -> "injury" 337 | Preparation_insufficient -> "preparation-insufficient" 338 339 let signal_of_code code = 340 let leveled make rest = 341 let* l = level_of_code rest in 342 Ok (make l) 343 in 344 match String.split_on_char ':' code with 345 | [ "sleep"; l ] -> leveled (fun l -> Evidence.Feedback.Sleep l) l 346 | [ "appetite"; l ] -> leveled (fun l -> Evidence.Feedback.Appetite l) l 347 | [ "readiness"; l ] -> leveled (fun l -> Evidence.Feedback.Readiness l) l 348 | [ "motivation"; l ] -> leveled (fun l -> Evidence.Feedback.Motivation l) l 349 | [ "difficulty"; l ] -> leveled (fun l -> Evidence.Feedback.Difficulty l) l 350 | [ "pain" ] -> Ok Evidence.Feedback.Pain 351 | [ "injury" ] -> Ok Evidence.Feedback.Injury 352 | [ "preparation-insufficient" ] -> 353 Ok Evidence.Feedback.Preparation_insufficient 354 | _ -> Error (Malformed (Printf.sprintf "signal %S" code)) 355 356 let encode_feedback report = 357 let reported_at = Timestamp.encode (Evidence.Feedback.reported_at report) in 358 let signals = 359 String.concat "," (List.map signal_code (Evidence.Feedback.signals report)) 360 in 361 Printf.sprintf "%s\t%s" reported_at signals 362 363 let decode_feedback text = 364 match String.split_on_char '\t' text with 365 | [ timestamp; signals ] -> ( 366 match Timestamp.decode timestamp with 367 | Error _ -> Error (Malformed "feedback timestamp") 368 | Ok reported_at -> 369 let codes = 370 String.split_on_char ',' signals 371 |> List.filter (fun s -> String.length s > 0) 372 in 373 let rec go acc = function 374 | [] -> Ok (List.rev acc) 375 | code :: tl -> ( 376 match signal_of_code code with 377 | Ok s -> go (s :: acc) tl 378 | Error _ as e -> e) 379 in 380 let* signals = go [] codes in 381 Ok (Evidence.Feedback.make ~reported_at signals)) 382 | _ -> Error (Malformed "feedback arity") 383