type lock = Ref of Ref_name.t | Packed_refs

let pp_lock ppf = function
  | Ref r -> Ref_name.pp ppf r
  | Packed_refs -> Fmt.string ppf "packed-refs"

type held = { lock : lock; path : Fpath.t; holds : Git.Hash.t option }
type facts = { target : Commit.t option; contains : bool }
type decision = Finish | Restart

(* doc/design.md, "Recovery": the target at the intent's new commit, or at a
   commit that contains it, is the landing having happened. That commit is the
   one move's, whichever land of it asks, so every land the move names
   finishes, or none does. *)
let decide (intent : Intent.t) facts =
  if
    facts.contains
    || Option.equal Commit.equal facts.target (Some intent.move.next)
  then Finish
  else Restart

type request = {
  id : Record.id;
  intent : Intent.t;
  role : Tidy.role;
  decision : decision;
  resumed : bool;
}

type deletion = { queued : Commit.t; landed : Commit.t }

type commit = {
  name : Branch.t;
  branch : deletion option;
  worktree : Fpath.t option;
  pin : Record.id option;
  intent : Record.id option;
}

type event =
  | Released
  | Released_leaving of { paths : Fpath.t list }
  | Unswitched
  | Kept
  | Keep_taken of Landing.t option
  | Tidy of Tidy.event
  | Committed
  | Branch_kept of Tidy.event
  | Held of { lock : lock; path : Fpath.t }
  | Unanswered of action * Machine.unanswered

and action =
  | Release of Intent.t
  | Unswitch of Intent.t
  | Keep of { name : Branch.t; serial : int; landing : Landing.t }
  | Tidy of Tidy.action
  | Commit of commit

type report = {
  landing : Landing.t;
  serial : int;
  tidy : Tidy.report option;
  clauses : string list;
  standing : bool;
}

type ending =
  | Finished of report
  | Restarted of { clauses : string list; standing : bool }

type step =
  | Releasing
  | Unswitching
  | Keeping
  | Tidying of Tidy.t
  | Committing of commit
  | Done of ending

type t = {
  request : request;
  step : step;
  serial : int;
  tidy : Tidy.report option;
  clauses : string list;  (** Newest first. *)
  kept : bool;  (** Whether the landing record is at its serial. *)
  keep_intent : bool;
      (** Whether the intent stays for the next run: a step it covers did not
          happen. *)
}

let machine = "settle"
let name t = t.request.intent.name

(* A landing record kept at a serial another record holds goes to the next
   one; past this many, it is said in the outcome instead. *)
let serial_tries = 64

let landing t =
  let i = t.request.intent in
  Landing.v ~submission:i.submission ~tree:i.tree ~checks:i.checks ~name:i.name
    ~queued:i.queued ~target:i.move.target ~was:i.onto ~landed:i.landed
    ~commits:i.commits

let clause t c = { t with clauses = c :: t.clauses }

let pp_step ppf = function
  | Releasing -> Fmt.string ppf "releasing the move's locks"
  | Unswitching -> Fmt.string ppf "switching the checkouts back"
  | Keeping -> Fmt.string ppf "keeping the pre-replay tip"
  | Tidying _ -> Fmt.string ppf "tidying"
  | Committing _ -> Fmt.string ppf "settling the refs"
  | Done _ -> Fmt.string ppf "done"

let stage t =
  match t.step with
  | Tidying tidy -> Tidy.stage tidy
  | step -> Fmt.str "settle: %a" pp_step step

let pp ppf t =
  Fmt.pf ppf "settlement of %a: %a" Branch.pp (name t) pp_step t.step

let pp_action ppf = function
  | Release _ -> Fmt.string ppf "release the move's locks"
  | Unswitch _ -> Fmt.string ppf "switch the checkouts back"
  | Keep { serial; _ } -> Fmt.pf ppf "keep the pre-replay tip as %d" serial
  | Tidy a -> Tidy.pp_action ppf a
  | Commit c ->
      let some o s = Option.map (fun _ -> s) o in
      let what =
        List.filter_map Fun.id
          [
            some c.branch (Fmt.str "delete %a" Branch.pp c.name);
            some c.pin "unpin";
            some c.intent "clear the intent";
          ]
      in
      Fmt.string ppf
        (match what with
        | [] -> "forget the hand-out"
        | _ -> String.concat ", " what)

let pp_event ppf = function
  | Released -> Fmt.string ppf "released"
  | Unswitched -> Fmt.string ppf "checkouts switched back"
  | Released_leaving { paths } ->
      Fmt.pf ppf "released, leaving %a" Fmt.(list ~sep:comma Fpath.pp) paths
  | Kept -> Fmt.string ppf "kept"
  | Keep_taken _ -> Fmt.string ppf "serial taken"
  | Tidy e -> Tidy.pp_event ppf e
  | Committed -> Fmt.string ppf "committed"
  | Branch_kept e -> Fmt.pf ppf "branch kept: %a" Tidy.pp_event e
  | Held { path; _ } -> Fmt.pf ppf "%a is held" Fpath.pp path
  | Unanswered (a, why) ->
      Fmt.pf ppf "%a: %a" pp_action a Machine.pp_unanswered why

let unexpected t e =
  Machine.unexpected machine ~state:(Fmt.str "%a" pp t)
    ~event:(Fmt.str "%a" pp_event e)

let finish t =
  let t =
    if t.keep_intent then clause t "the intent stays for the next run" else t
  in
  let ending =
    match t.request.decision with
    | Finish ->
        Finished
          {
            landing = landing t;
            serial = t.serial;
            tidy = t.tidy;
            clauses = List.rev t.clauses;
            standing = t.keep_intent;
          }
    | Restart ->
        Restarted { clauses = List.rev t.clauses; standing = t.keep_intent }
  in
  ({ t with step = Done ending }, [])

(* The settlement's refs, in one transaction: the branch's deletion when
   [branch]; once the tidy ran, the hand-out records of the worktree the
   intent records and the pin; and the intent, cleared once every step it
   covers happened, else left for the next run, which settles it again. *)
let commit t ~branch ~tidied =
  let i = t.request.intent in
  {
    name = i.name;
    branch =
      (if branch then Some { queued = i.queued; landed = i.move.next } else None);
    worktree = (if tidied then i.worktree else None);
    pin = (if tidied then Some i.entry else None);
    intent = (if t.keep_intent then None else Some t.request.id);
  }

let commit_rest t ~tidied =
  let c = commit t ~branch:false ~tidied in
  match c with
  | { branch = None; worktree = None; pin = None; intent = None; _ } -> finish t
  | c -> ({ t with step = Committing c }, [ Commit c ])

(* The tidy goes on; the deletion of the branch it waits on is made with the
   rest of the settlement's refs. *)
let tidying t tidy actions =
  let t = { t with step = Tidying tidy } in
  let actions = List.map (fun a : action -> Tidy a) actions in
  if Tidy.deleting tidy then
    (t, actions @ [ Commit (commit t ~branch:true ~tidied:true) ])
  else (t, actions)

let keep t =
  ( { t with step = Keeping },
    [ Keep { name = name t; serial = t.serial; landing = landing t } ] )

(* A replayed branch whose pre-replay commits no landing record keeps is left
   at them: deleting or moving it would make them unreachable. *)
let tidy t =
  let i = t.request.intent in
  if (not t.kept) && not (Commit.equal i.queued i.landed) then
    (* Its pin stays too: the next land of the name answers from the target,
       which holds its changes. *)
    commit_rest ~tidied:false
      (clause t
         (Fmt.str
            "%a stays queued at its commits, which no landing record keeps"
            Branch.pp i.name))
  else
    let tidy, actions =
      Tidy.v
        {
          name = i.name;
          queued = i.queued;
          landed = i.landed;
          target = i.move.target;
          role = t.request.role;
          keep_branch = i.keep_branch;
          resumed = t.request.resumed;
          pool = i.worktree;
        }
    in
    tidying t tidy actions

let main t =
  match t.request.decision with
  | Finish -> keep t
  | Restart when t.request.intent.checkouts <> [] ->
      ({ t with step = Unswitching }, [ Unswitch t.request.intent ])
  | Restart -> commit_rest t ~tidied:false

let v request =
  let t =
    {
      request;
      step = Releasing;
      serial = request.intent.serial;
      tidy = None;
      clauses = [];
      kept = false;
      keep_intent = false;
    }
  in
  if request.resumed then (t, [ Release request.intent ]) else main t

let held_clause t path what =
  clause t (Fmt.str "%a is held, so %s" Fpath.pp path what)

let failed_clause t a why =
  clause t
    (Fmt.str "%a could not be done: %a" pp_action a Machine.pp_unanswered why)

(* A lock of the commit's transaction is held: nothing of it was made. *)
let held_commit t (c : commit) path =
  let t =
    if Option.is_some c.intent then { t with keep_intent = true } else t
  in
  match c.pin with
  | Some _ -> held_clause t path (Branch.to_string (name t) ^ " stays queued")
  | None -> clause t (Fmt.str "%a is held" Fpath.pp path)

let on_tidy t ~now tidy te =
  match Tidy.incoming tidy ~now te with
  | Error _ as e -> e
  | Ok (tidy, actions) -> (
      match Tidy.ending tidy with
      | None -> Ok (tidying t tidy actions)
      | Some report ->
          let t = { t with tidy = Some report } in
          let t = match report.kept with Some k -> clause t k | None -> t in
          (* The branch is deleted only with every other ref of the
             settlement, in its one transaction. *)
          if report.deleted then Ok (finish t)
          else
            let t, more = commit_rest t ~tidied:true in
            Ok (t, List.map (fun a : action -> Tidy a) actions @ more))

let incoming t ~now e =
  let nm = Branch.to_string (name t) in
  match (t.step, e) with
  | Releasing, Released -> Ok (main t)
  | Releasing, Released_leaving { paths } ->
      Ok
        (main
           (List.fold_left
              (fun t path ->
                clause t
                  (Fmt.str
                     "%a holds what the move did not write there, so it stays"
                     Fpath.pp path))
              t paths))
  | Releasing, Unanswered ((Release _ as a), why) ->
      Ok (main { (failed_clause t a why) with keep_intent = true })
  | Unswitching, Unswitched -> Ok (commit_rest t ~tidied:false)
  | Unswitching, Unanswered ((Unswitch _ as a), why) ->
      Ok
        (commit_rest ~tidied:false
           { (failed_clause t a why) with keep_intent = true })
  | Keeping, Kept -> Ok (tidy { t with kept = true })
  | Keeping, Keep_taken (Some l) when Landing.equal l (landing t) ->
      Ok (tidy { t with kept = true })
  | Keeping, Keep_taken _ when t.serial < t.request.intent.serial + serial_tries
    ->
      Ok (keep { t with serial = t.serial + 1 })
  | Keeping, Keep_taken _ ->
      Ok
        (tidy
           (clause t
              (Fmt.str "no serial under refs/mq/landed/ was free for %s" nm)))
  | Keeping, Held { path; _ } ->
      Ok
        (tidy
           {
             (held_clause t path "the commits before the replay are not kept") with
             keep_intent = true;
           })
  | Keeping, Unanswered ((Keep _ as a), why) ->
      Ok (tidy { (failed_clause t a why) with keep_intent = true })
  | Tidying tidy, Tidy te -> on_tidy t ~now tidy te
  | Tidying tidy, Unanswered (Tidy a, why) ->
      on_tidy t ~now tidy (Tidy.unanswered a why)
  | Tidying tidy, Committed when Tidy.deleting tidy ->
      on_tidy t ~now tidy Tidy.Branch_deleted
  | Tidying tidy, Branch_kept te when Tidy.deleting tidy ->
      on_tidy t ~now tidy te
  | Tidying tidy, Unanswered ((Commit _ as a), why) when Tidy.deleting tidy ->
      Ok (finish { (failed_clause t a why) with keep_intent = true })
  | Committing _, Committed -> Ok (finish t)
  | Committing c, Held { path; _ } -> Ok (finish (held_commit t c path))
  | Committing _, Unanswered ((Commit _ as a), why) ->
      Ok (finish { (failed_clause t a why) with keep_intent = true })
  | Done _, _ -> Ok (t, [])
  | ( (Releasing | Unswitching | Keeping | Tidying _ | Committing _),
      ( Released | Released_leaving _ | Unswitched | Kept | Keep_taken _
      | Tidy _ | Committed | Branch_kept _ | Held _ | Unanswered _ ) ) ->
      unexpected t e

let timer t ~now:_ = Ok (t, [])
let next_timeout _ = None
let ending t = match t.step with Done e -> Some e | _ -> None

let task : action -> Machine.Task.t = function
  | Tidy a -> Machine.Task.under "tidy" (Tidy.task a)
  | Release _ | Unswitch _ | Keep _ | Commit _ -> Machine.Task.Now

let unanswered a why = Unanswered (a, why)
let plural n one = if n = 1 then Fmt.str "1 %s" one else Fmt.str "%d %ss" n one

let recovered_outcome ~killed r =
  let l = r.landing in
  let detail =
    String.concat "; "
      (Fmt.str "%s, finished after a run that %s"
         (plural l.commits "commit")
         (if killed then "was killed" else "stopped before its end")
      :: r.clauses)
  in
  Outcome.v ~branch:l.name ~target:(Outcome.Into l.target) ~landed:true
    ~published:false
    ?worktree:(Option.bind r.tidy (fun (t : Tidy.report) -> t.worktree))
    Outcome.Landed detail