type error =
  | Malformed of string
  | Unknown_exercise of string
  | Unknown_routine of string
  | Unknown_workout_name of { routine : string; workout : string }
  | Replay_rejected of string

let pp_error ppf = function
  | Malformed detail -> Format.fprintf ppf "malformed record: %s" detail
  | Unknown_exercise id -> Format.fprintf ppf "unknown exercise %S" id
  | Unknown_routine name -> Format.fprintf ppf "unknown routine %S" name
  | Unknown_workout_name { routine; workout } ->
      Format.fprintf ppf "routine %S has no workout %S" routine workout
  | Replay_rejected detail ->
      Format.fprintf ppf "stored record rejected: %s" detail

(* --- extension and outcome codes --- *)

let extension_code : Evidence.Stimulus.extension -> string = function
  | Forced_reps -> "forced"
  | Negatives -> "negatives"
  | Rest_pause -> "rest-pause"
  | Static_hold -> "static"

let extension_of_code = function
  | "forced" -> Ok Evidence.Stimulus.Forced_reps
  | "negatives" -> Ok Evidence.Stimulus.Negatives
  | "rest-pause" -> Ok Evidence.Stimulus.Rest_pause
  | "static" -> Ok Evidence.Stimulus.Static_hold
  | other -> Error (Malformed (Printf.sprintf "extension %S" other))

let encode_outcome (outcome : Evidence.Stimulus.outcome) =
  match outcome with
  | Positive_failure -> "positive"
  | Beyond_failure (first, rest) ->
      "beyond:" ^ String.concat "," (List.map extension_code (first :: rest))

let decode_outcome text =
  if String.equal text "positive" then Ok Evidence.Stimulus.Positive_failure
  else
    match String.split_on_char ':' text with
    | [ "beyond"; codes ] -> (
        match String.split_on_char ',' codes with
        | [] | [ "" ] -> Error (Malformed "empty beyond-failure")
        | first :: rest ->
            let ( let* ) = Result.bind in
            let* first = extension_of_code first in
            let rec go acc = function
              | [] -> Ok (List.rev acc)
              | code :: tl -> (
                  match extension_of_code code with
                  | Ok e -> go (e :: acc) tl
                  | Error _ as e -> e)
            in
            let* rest = go [] rest in
            Ok (Evidence.Stimulus.Beyond_failure (first, rest)))
    | _ -> Error (Malformed (Printf.sprintf "outcome %S" text))

(* --- efforts and stimuli --- *)

let encode_effort effort =
  let exercise = Evidence.Stimulus.Effort.exercise effort in
  Printf.sprintf "%s\t%h\t%d\t%s"
    (Exercise.id exercise :> string)
    (Evidence.Stimulus.Effort.load effort)
    (Evidence.Stimulus.Effort.reps effort)
    (encode_outcome (Evidence.Stimulus.Effort.outcome effort))

let encode_stimulus ~slot stimulus =
  match Evidence.Stimulus.delivery stimulus with
  | Evidence.Stimulus.Single effort ->
      Printf.sprintf "stimulus\t%d\tsingle\t%s" slot (encode_effort effort)
  | Evidence.Stimulus.Pair { first; second } ->
      Printf.sprintf "stimulus\t%d\tpair\t%s\t%s" slot (encode_effort first)
        (encode_effort second)

let ( let* ) = Result.bind

let decode_effort = function
  | [ exid; load; reps; outcome ] -> (
      match Exercise.find_id exid with
      | None -> Error (Unknown_exercise exid)
      | Some exercise -> (
          match (float_of_string_opt load, int_of_string_opt reps) with
          | Some load, Some reps ->
              let* outcome = decode_outcome outcome in
              Ok (Evidence.Stimulus.Effort.make ~exercise ~load ~reps ~outcome)
          | _ -> Error (Malformed "effort load/reps")))
  | _ -> Error (Malformed "effort arity")

(* Decode a stimulus and the slot it filled. The current format prefixes the
   slot; a record from before slots were stored omits it, and replays in
   performance order through [add_stimulus] instead. *)
let decode_stimulus fields =
  let delivery = function
    | "single" :: rest ->
        let* effort = decode_effort rest in
        Ok (Evidence.Stimulus.make (Evidence.Stimulus.Single effort))
    | "pair" :: rest -> (
        match rest with
        | [ a; b; c; d; e; f; g; h ] ->
            let* first = decode_effort [ a; b; c; d ] in
            let* second = decode_effort [ e; f; g; h ] in
            Ok
              (Evidence.Stimulus.make
                 (Evidence.Stimulus.Pair { first; second }))
        | _ -> Error (Malformed "pair arity"))
    | _ -> Error (Malformed "stimulus delivery")
  in
  match fields with
  | slot :: rest when Option.is_some (int_of_string_opt slot) ->
      let* stimulus = delivery rest in
      Ok (Some (Option.get (int_of_string_opt slot)), stimulus)
  | rest ->
      let* stimulus = delivery rest in
      Ok (None, stimulus)

(* --- clearance --- *)

let encode_clearance clearance =
  match Recovery.basis clearance with
  | Recovery.Recovered -> "clearance\trecovered"
  | Recovery.Overridden { rested; recommended } ->
      Printf.sprintf "clearance\toverridden\t%d\t%d"
        (Recovery.duration_to_seconds rested)
        (Recovery.duration_to_seconds recommended)

(* Recovery exposes only hours/days constructors, so derive an arbitrary
   second-valued duration through elapsed: since=0, now=secs yields exactly
   [secs] seconds. *)
let seconds_duration secs =
  Recovery.elapsed
    ~since:(Recovery.timestamp_of_unix_seconds 0)
    ~now:(Recovery.timestamp_of_unix_seconds secs)

(* A clearance cannot be minted directly; it is derived from a readiness.
   [Recovered] comes from a [Ready] reading; an override needs a [Recovering]
   reading carrying the stored durations. *)
let decode_clearance = function
  | [ "recovered" ] -> Ok (Option.get (Recovery.clear Recovery.Ready))
  | [ "overridden"; rested; recommended ] -> (
      match (int_of_string_opt rested, int_of_string_opt recommended) with
      | Some rested, Some recommended ->
          Ok
            (Recovery.override
               (Recovery.Recovering
                  {
                    rested = seconds_duration rested;
                    recommended = seconds_duration recommended;
                  }))
      | _ -> Error (Malformed "clearance durations"))
  | _ -> Error (Malformed "clearance basis")

(* --- workout --- *)

let encode_workout ~routine_name workout =
  let buf = Buffer.create 256 in
  let line s =
    Buffer.add_string buf s;
    Buffer.add_char buf '\n'
  in
  line (Printf.sprintf "routine\t%s" routine_name);
  line
    (Printf.sprintf "prescription\t%s"
       (Prescription.Workout.name (Evidence.Workout.prescription workout)));
  line (encode_clearance (Evidence.Workout.clearance workout));
  line
    (Printf.sprintf "started\t%s"
       (Timestamp.encode (Evidence.Workout.started_at workout)));
  (match Evidence.Workout.ended_at workout with
  | Some ended -> line (Printf.sprintf "ended\t%s" (Timestamp.encode ended))
  | None -> ());
  List.iter
    (fun (slot, stimulus) -> line (encode_stimulus ~slot stimulus))
    (Evidence.Workout.performed workout);
  Buffer.contents buf

(* A fully-parsed header, gathered before any replay. Parsing produces this
   typed record; replay consumes it. Keeping the two phases apart removes the
   mutable accumulators the old single pass needed. *)
type parsed = {
  routine_name : string;
  prescription_name : string;
  clearance : Recovery.clearance;
  started_at : Recovery.timestamp;
  ended_at : Recovery.timestamp option;
  stimuli : (int option * Evidence.Stimulus.t) list;
      (** Performance order, each with the slot it filled when known. *)
}

(* Fields accumulated while folding over lines; every field is optional until
   its line is seen. [stimuli] is reversed for O(1) prepend and flipped once at
   the end. *)
type acc = {
  a_routine : string option;
  a_prescription : string option;
  a_clearance : Recovery.clearance option;
  a_started : Recovery.timestamp option;
  a_ended : Recovery.timestamp option;
  a_stimuli_rev : (int option * Evidence.Stimulus.t) list;
}

let empty_acc =
  {
    a_routine = None;
    a_prescription = None;
    a_clearance = None;
    a_started = None;
    a_ended = None;
    a_stimuli_rev = [];
  }

let parse_timestamp label text =
  match Timestamp.decode text with
  | Ok timestamp -> Ok timestamp
  | Error _ -> Error (Malformed label)

(* Fold one line into the accumulator. A line either sets a header field or
   appends a stimulus; anything else is malformed. *)
let step acc = function
  | [ "routine"; name ] -> Ok { acc with a_routine = Some name }
  | [ "prescription"; name ] -> Ok { acc with a_prescription = Some name }
  | "clearance" :: rest ->
      let* c = decode_clearance rest in
      Ok { acc with a_clearance = Some c }
  | [ "started"; text ] ->
      let* timestamp = parse_timestamp "started timestamp" text in
      Ok { acc with a_started = Some timestamp }
  | [ "ended"; text ] ->
      let* timestamp = parse_timestamp "ended timestamp" text in
      Ok { acc with a_ended = Some timestamp }
  | "stimulus" :: rest ->
      let* s = decode_stimulus rest in
      Ok { acc with a_stimuli_rev = s :: acc.a_stimuli_rev }
  | fields -> Error (Malformed (String.concat "|" fields))

(* Parse the whole text into a typed header, or fail. Mandatory fields are
   checked here so replay never sees a partial record. *)
let parse text =
  let lines =
    String.split_on_char '\n' text
    |> List.filter (fun l -> String.length l > 0)
    |> List.map (fun l -> String.split_on_char '\t' l)
  in
  let rec fold acc = function
    | [] -> Ok acc
    | line :: tl ->
        let* acc = step acc line in
        fold acc tl
  in
  let* acc = fold empty_acc lines in
  match (acc.a_routine, acc.a_prescription, acc.a_clearance, acc.a_started) with
  | Some routine_name, Some prescription_name, Some clearance, Some started_at
    ->
      Ok
        {
          routine_name;
          prescription_name;
          clearance;
          started_at;
          ended_at = acc.a_ended;
          stimuli = List.rev acc.a_stimuli_rev;
        }
  | _ -> Error (Malformed "missing header fields")

(* Resolve the prescription named in the header against the catalog. *)
let resolve_prescription ~find_routine parsed =
  match find_routine parsed.routine_name with
  | None -> Error (Unknown_routine parsed.routine_name)
  | Some routine -> (
      match
        List.find_opt
          (fun w ->
            String.equal (Prescription.Workout.name w) parsed.prescription_name)
          (Prescription.Routine.workouts routine)
      with
      | Some prescription -> Ok prescription
      | None ->
          Error
            (Unknown_workout_name
               {
                 routine = parsed.routine_name;
                 workout = parsed.prescription_name;
               }))

(* Drive the core constructors from a typed header. The core raises on a
   rejected stimulus; catch it once here and report it as data corruption. *)
let replay ~prescription parsed =
  try
    let workout =
      Evidence.Workout.start prescription ~clearance:parsed.clearance
        ~started_at:parsed.started_at
    in
    let workout =
      List.fold_left
        (fun workout (slot, stimulus) ->
          match slot with
          | Some slot -> Evidence.Workout.record_at workout ~slot stimulus
          | None -> Evidence.Workout.add_stimulus workout stimulus)
        workout parsed.stimuli
    in
    let workout =
      match parsed.ended_at with
      | Some ended_at -> Evidence.Workout.finish workout ~ended_at
      | None -> workout
    in
    Ok workout
  with Evidence.Workout.Invalid err ->
    Error (Replay_rejected (Format.asprintf "%a" Evidence.Workout.pp_error err))

let decode_workout ~find_routine text =
  let* parsed = parse text in
  let* prescription = resolve_prescription ~find_routine parsed in
  replay ~prescription parsed

(* --- subjective feedback --- *)

let level_code (l : Evidence.Feedback.level) =
  string_of_int (Evidence.Feedback.level_to_score l)

let level_of_code code =
  match int_of_string_opt code with
  | Some n -> (
      match Evidence.Feedback.level_of_score n with
      | Some l -> Ok l
      | None -> Error (Malformed (Printf.sprintf "level %S" code)))
  | None -> Error (Malformed (Printf.sprintf "level %S" code))

let signal_code : Evidence.Feedback.signal -> string = function
  | Sleep l -> "sleep:" ^ level_code l
  | Appetite l -> "appetite:" ^ level_code l
  | Readiness l -> "readiness:" ^ level_code l
  | Motivation l -> "motivation:" ^ level_code l
  | Difficulty l -> "difficulty:" ^ level_code l
  | Pain -> "pain"
  | Injury -> "injury"
  | Preparation_insufficient -> "preparation-insufficient"

let signal_of_code code =
  let leveled make rest =
    let* l = level_of_code rest in
    Ok (make l)
  in
  match String.split_on_char ':' code with
  | [ "sleep"; l ] -> leveled (fun l -> Evidence.Feedback.Sleep l) l
  | [ "appetite"; l ] -> leveled (fun l -> Evidence.Feedback.Appetite l) l
  | [ "readiness"; l ] -> leveled (fun l -> Evidence.Feedback.Readiness l) l
  | [ "motivation"; l ] -> leveled (fun l -> Evidence.Feedback.Motivation l) l
  | [ "difficulty"; l ] -> leveled (fun l -> Evidence.Feedback.Difficulty l) l
  | [ "pain" ] -> Ok Evidence.Feedback.Pain
  | [ "injury" ] -> Ok Evidence.Feedback.Injury
  | [ "preparation-insufficient" ] ->
      Ok Evidence.Feedback.Preparation_insufficient
  | _ -> Error (Malformed (Printf.sprintf "signal %S" code))

let encode_feedback report =
  let reported_at = Timestamp.encode (Evidence.Feedback.reported_at report) in
  let signals =
    String.concat "," (List.map signal_code (Evidence.Feedback.signals report))
  in
  Printf.sprintf "%s\t%s" reported_at signals

let decode_feedback text =
  match String.split_on_char '\t' text with
  | [ timestamp; signals ] -> (
      match Timestamp.decode timestamp with
      | Error _ -> Error (Malformed "feedback timestamp")
      | Ok reported_at ->
          let codes =
            String.split_on_char ',' signals
            |> List.filter (fun s -> String.length s > 0)
          in
          let rec go acc = function
            | [] -> Ok (List.rev acc)
            | code :: tl -> (
                match signal_of_code code with
                | Ok s -> go (s :: acc) tl
                | Error _ as e -> e)
          in
          let* signals = go [] codes in
          Ok (Evidence.Feedback.make ~reported_at signals))
  | _ -> Error (Malformed "feedback arity")