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