type request = { remote : string option; no_wait : bool }
type context = { rules : Rules.t; rules_branch : Branch.t; scheduler : bool }

type landing = {
  submission : Submission.t;
  name : Branch.t;
  landed : Commit.t;
  since : Commit.t;
  pinned : bool;
  taken : bool;
}

type facts = {
  branch : Branch.t;
  remote : string;
  local : Commit.t option;
  agreed : Commit.t option;
  seen : Commit.t option;
  tracking : Commit.t option;
  contains : (Commit.t * Commit.t) list;
  landings : landing list;
  foreign : int;
  tags : string list;
  checkouts : Fpath.t list;
  pulled : int;
  replaced : bool;
  held : Commit.t option;
}

type replay = { name : Branch.t; target : Branch.t; was : Commit.t }

let made_with_git tip = Branch.v ("git-" ^ Commit.short tip)

type write =
  | Rescue of { off : Branch.t; commit : Commit.t }
  | Requeue of { entry : Entry.t; local : Commit.t }
  | Reset of {
      branch : Branch.t;
      expected : Commit.t option;
      value : Commit.t;
      checkouts : Fpath.t list;
    }
  | Seen of {
      remote : string;
      branch : Branch.t;
      seen : Commit.t option;
      tracking : Commit.t option;
      value : Commit.t;
    }
  | Track of { branch : Branch.t; remote : string }

type last = { seen : Commit.t option; tracking : Commit.t option }

type fetched = {
  values : (Branch.t * Commit.t) list;
  last : (Branch.t * last) list;
}

type event =
  | Local_read of Push.local list
  | Fetched of { remote : string; fetched : fetched }
  | Unreachable of { remote : string; why : string }
  | Unsupported of { remote : string; why : string }
  | Untrusted of { remote : string; why : string }
  | Facts_read of facts list
  | Written
  | Requeued of Record.id
  | Lost of string
  | Overwritten of { checkout : Fpath.t; paths : string list }
  | Unmerged of { checkout : Fpath.t; paths : string list }
  | Unpinned
  | Signalled of Signal.t
  | Unanswered of action * Machine.unanswered

and action =
  | Read_local
  | Fetch of { remote : string; branches : Branch.t list }
  | Read_facts of {
      fetched : (string * fetched) list;
      branches : (string * Branch.t) list;
      takes : (Branch.t * Branch.t) list;
    }
  | Write of write
  | Unpin of { name : Branch.t; expected : Record.id }
  | Journal of { branch : Branch.t; kind : Event.kind }

type ending =
  | Reconciled of {
      report : Report.t;
      replays : replay list;
      remotes : string;
      pulled : int;
    }
  | Stopped of Outcome.t

type plan = {
  writes : write list;
  replays : replay list;
  named : string list;
  pulled : int;
  remotes : string list;
}

type phase =
  | Reading_local
  | Fetching of {
      all : (string * Branch.t list) list;
      current : string * Branch.t list;
      rest : (string * Branch.t list) list;
      fetched : (string * fetched) list;
    }
  | Reading_facts
  | Writing of {
      plan : plan;
      rest : write list;
      pins : (Branch.t * Record.id) list;
    }
  | Unpinning of {
      current : Branch.t;  (** The landing whose pin is being withdrawn. *)
      rest : (Branch.t * Record.id) list;
      outcome : Outcome.t;
    }
  | Done of ending

type t = {
  context : context;
  request : request;
  phase : phase;
  interrupted : bool;
      (** A signal arrived while the pull wrote: it finishes its writes and
          lands nothing. *)
}

let machine = "pull"

let v context request =
  ( { context; request; phase = Reading_local; interrupted = false },
    [ Read_local ] )

let plural n one = if n = 1 then Fmt.str "1 %s" one else Fmt.str "%d %ss" n one
let outcome ?branch ?next word = Fmt.kstr (Outcome.v ?branch ?next word)
let finish t e = Ok ({ t with phase = Done e }, [])
let stop t o = finish t (Stopped o)

(* {1 What is pulled from where} *)

let literals ctx = Rules.literals ctx.rules @ [ ctx.rules_branch ]
let in_dag ctx b = Branch.equal b ctx.rules_branch || Rules.names ctx.rules b

(* Every branch of the DAG, the rules branch, and every local branch a
   pattern names, each with the remote it is pulled from: REMOTE, its own,
   else the one the DAG's other branches are pulled from. *)
let sources ctx (request : request) (locals : Push.local list) =
  let local b =
    List.find_opt (fun (l : Push.local) -> Branch.equal l.branch b) locals
  in
  let names =
    List.sort_uniq Branch.compare
      (literals ctx
      @ List.filter_map
          (fun (l : Push.local) ->
            if in_dag ctx l.branch then Some l.branch else None)
          locals)
  in
  let fallback =
    List.find_map
      (fun b -> Option.bind (local b) (fun (l : Push.local) -> l.pull_remote))
      names
  in
  List.filter_map
    (fun b ->
      let remote =
        match request.remote with
        | Some r -> Some r
        | None -> (
            match
              Option.bind (local b) (fun (l : Push.local) -> l.pull_remote)
            with
            | Some r -> Some r
            | None -> fallback)
      in
      Option.map (fun r -> (r, b)) remote)
    names

let by_remote pairs =
  List.sort_uniq String.compare (List.map fst pairs)
  |> List.map (fun r ->
      ( r,
        List.filter_map
          (fun (r', b) -> if String.equal r r' then Some b else None)
          pairs ))

(* {1 One branch} *)

let tracking_of (f : facts) =
  Fmt.kstr Branch.v "%s/%a" f.remote Branch.pp f.branch

let contains (f : facts) a b =
  Commit.equal a b
  || List.exists (fun (x, y) -> Commit.equal x a && Commit.equal y b) f.contains

(* The value this machine last saw on the remote: its record under
   [refs/mq/seen/], else the remote-tracking branch, which is what Git
   fetched last on a machine where mq has not pulled or pushed yet. *)
let last_seen (f : facts) =
  match f.seen with Some _ as s -> s | None -> f.tracking

let returned (l : landing) =
  if l.taken then Fmt.kstr Branch.v "%a-returned" Branch.pp l.name else l.name

let seen_write (f : facts) value =
  match f.seen with
  | Some s
    when Commit.equal s value
         && Option.equal Commit.equal f.tracking (Some value) ->
      []
  | _ ->
      [
        Seen
          {
            remote = f.remote;
            branch = f.branch;
            seen = f.seen;
            tracking = f.tracking;
            value;
          };
      ]

let kept r = Fmt.str "mq rescued %a: kept" Branch.pp r

let rescue (f : facts) ~agreed =
  match last_seen f with
  | Some s when not (contains f s agreed) ->
      ( [ Rescue { off = tracking_of f; commit = s } ],
        [
          Fmt.str
            "%a dropped commits this machine had seen there: kept by %a's \
             reflog"
            Branch.pp (tracking_of f) Ref_name.pp Ref_name.keep;
        ] )
  | _ -> ([], [])

let err_refused (f : facts) ?next fmt =
  Fmt.kstr
    (fun s -> Error (outcome ~branch:f.branch ?next Outcome.Refused "%s" s))
    fmt

(* Each landing not pinned yet is pinned again under the name it comes back
   as, verified against the local branch. *)
let requeues (f : facts) ~local =
  List.filter_map
    (fun (l : landing) ->
      if l.pinned then None
      else
        let entry =
          Entry.v ~submission:l.submission ~name:(returned l) ~tip:l.landed
            ~target:f.branch ~since:l.since ~keep_branch:false ~retry:false ()
        in
        Some (Requeue { entry; local }))
    f.landings

let replays (f : facts) =
  List.map
    (fun (l : landing) ->
      {
        name = (if l.pinned then l.name else returned l);
        target = f.branch;
        was = l.landed;
      })
    f.landings

let diverged (f : facts) ~agreed ~local =
  if f.foreign > 0 then
    err_refused f
      "%s on %a since %s/%a as this machine last saw it %s on no line from it \
       through this machine's landings: nothing moved"
      (plural f.foreign "commit")
      Branch.pp f.branch f.remote Branch.pp f.branch
      (if f.foreign = 1 then "is" else "are")
  else
    match f.tags with
    | tag :: _ ->
        err_refused f ~next:("git tag -d " ^ tag)
          "%s tags a commit a pull would replay on %a, and a tag is never \
           replayed: nothing moved"
          tag Branch.pp f.branch
    | [] ->
        let rescues, named = rescue f ~agreed in
        let reset =
          Reset
            {
              branch = f.branch;
              expected = Some local;
              value = agreed;
              checkouts = f.checkouts;
            }
        in
        Ok
          ( rescues @ requeues f ~local @ (reset :: seen_write f agreed),
            replays f,
            named )

let reconcile (f : facts) =
  match (f.agreed, f.local, last_seen f) with
  | None, _, Some _ ->
      Ok
        ( [],
          [],
          Fmt.kstr Option.some
            "%a was deleted on %s: mq deletes no branch of the DAG, and this \
             one stays here"
            Branch.pp f.branch f.remote )
  | None, _, None -> Ok ([], [], None)
  | Some agreed, None, _ ->
      Ok
        ( Reset
            {
              branch = f.branch;
              expected = None;
              value = agreed;
              checkouts = [];
            }
          :: Track { branch = f.branch; remote = f.remote }
          :: seen_write f agreed,
          [],
          None )
  | Some agreed, Some local, _ when Commit.equal agreed local ->
      Ok (seen_write f agreed, [], None)
  | Some agreed, Some local, _ when contains f local agreed ->
      let rescues, named = rescue f ~agreed in
      Ok
        ( rescues
          @ [
              Reset
                {
                  branch = f.branch;
                  expected = Some local;
                  value = agreed;
                  checkouts = f.checkouts;
                };
            ]
          @ seen_write f agreed,
          [],
          match named with n :: _ -> Some n | [] -> None )
  | Some agreed, Some local, seen
    when contains f agreed local
         && Option.fold ~none:true ~some:(fun s -> contains f s agreed) seen
         && not (f.replaced && f.landings <> []) ->
      Ok (seen_write f agreed, [], None)
  | Some _, Some _, None ->
      err_refused f
        "this machine has no record of the value it last saw on %s/%a (%a), so \
         it cannot tell its own landings from the remote's: nothing moved"
        f.remote Branch.pp f.branch Ref_name.pp
        (Ref_name.seen (tracking_of f))
  | Some agreed, Some local, Some _ -> (
      match diverged f ~agreed ~local with
      | Error _ as e -> e
      | Ok (writes, replays, named) ->
          Ok (writes, replays, match named with n :: _ -> Some n | [] -> None))

(* The rules branch moves only by fast-forward, as git merge --ff-only moves
   a branch: a remote copy rewound behind the value this machine last saw
   there, or one that diverged from this machine's, is refused by name, and
   no landing into the rules is replayed (doc/configuration.md). *)
let reconcile_rules (f : facts) =
  match (f.agreed, f.local) with
  | Some agreed, Some local
    when (not (contains f local agreed)) && not (contains f agreed local) ->
      err_refused f
        "%a and %s/%a have diverged: the rules move only by fast-forward; \
         nothing moved"
        Branch.pp f.branch f.remote Branch.pp f.branch
  | Some agreed, Some local
    when (not (Commit.equal agreed local))
         && contains f agreed local
         && Option.fold ~none:false
              ~some:(fun s -> not (contains f s agreed))
              (last_seen f) ->
      err_refused f ~next:("mq push " ^ f.remote)
        "%s/%a was rewound behind the value this machine last saw there: %a \
         keeps its rules; nothing moved"
        f.remote Branch.pp f.branch Branch.pp f.branch
  | _ -> reconcile f

(* A branch that takes from one the pull replays landings beneath, or takes
   back, goes back to the newest of its commits the new source holds, or to
   the agreed copy when that is newer, its tip kept by a line of
   refs/mq/keep's reflog; none of its landings is replayed, and the next run
   lands the source into it again (doc/machines.md, "Every machine lands
   staging into main itself"). The bool says whether it moved. *)
let take_back (f : facts) ~source ~local =
  let value =
    match (f.held, f.agreed) with
    | Some h, Some a -> Some (if contains f a h then h else a)
    | Some h, None -> Some h
    | None, a -> a
  in
  let seen = match f.agreed with Some a -> seen_write f a | None -> [] in
  match value with
  | None ->
      err_refused f
        "%a holds commits %a no longer holds and shares none with it: nothing \
         moved"
        Branch.pp f.branch Branch.pp source
  | Some v when Commit.equal v local -> Ok ((seen, [], None), false)
  | Some v ->
      let keep =
        if contains f local v then []
        else [ Rescue { off = f.branch; commit = local } ]
      in
      let reset =
        Reset
          {
            branch = f.branch;
            expected = Some local;
            value = v;
            checkouts = f.checkouts;
          }
      in
      let named =
        Fmt.kstr Option.some
          "%a is taken back to the newest of its commits %a holds, its tip \
           kept by %a's reflog: the next run lands %a into it again"
          Branch.pp f.branch Branch.pp source Ref_name.pp Ref_name.keep
          Branch.pp source
      in
      Ok ((keep @ (reset :: seen), [], named), true)

let plan ctx facts =
  let order (f : facts) =
    let rec depth b =
      match Rules.takes ctx.rules b with
      | Some s when not (Branch.equal s b) -> 1 + depth s
      | _ -> 0
    in
    depth f.branch
  in
  let facts = List.stable_sort (fun a b -> compare (order a) (order b)) facts in
  (* [beneath] is the branches moved beneath what takes from them. *)
  let step (results, beneath) (f : facts) =
    let r, moved =
      match (Rules.takes ctx.rules f.branch, f.local) with
      | Some source, Some local
        when List.exists (Branch.equal source) beneath
             && not (Option.equal Commit.equal f.local f.agreed) -> (
          match take_back f ~source ~local with
          | Ok (p, moved) -> (Ok p, moved)
          | Error _ as e -> (e, false))
      | _ -> (
          let r =
            if Branch.equal f.branch ctx.rules_branch then reconcile_rules f
            else reconcile f
          in
          (r, match r with Ok (_, _ :: _, _) -> true | _ -> false))
    in
    ((f, r) :: results, if moved then f.branch :: beneath else beneath)
  in
  let results = List.rev (fst (List.fold_left step ([], []) facts)) in
  match List.find_map (function _, Error o -> Some o | _ -> None) results with
  | Some o -> Error o
  | None ->
      let plans =
        List.filter_map
          (function f, Ok p -> Some (f, p) | _, Error _ -> None)
          results
      in
      Ok
        {
          writes = List.concat_map (fun (_, (w, _, _)) -> w) plans;
          replays = List.concat_map (fun (_, (_, r, _)) -> r) plans;
          named = List.filter_map (fun (_, (_, _, n)) -> n) plans;
          pulled =
            List.fold_left (fun n ((f : facts), _) -> n + f.pulled) 0 plans;
          remotes =
            List.sort_uniq String.compare
              (List.map (fun ((f : facts), _) -> f.remote) plans);
        }

(* {1 The report} *)

let remotes (p : plan) =
  match p.remotes with [] -> "no remote" | rs -> String.concat ", " rs

let report (p : plan) =
  let remotes = remotes p in
  let subject =
    if p.pulled = 0 then Fmt.str "nothing new from %s" remotes
    else Fmt.str "%s from %s" (plural p.pulled "commit") remotes
  in
  let detail =
    match p.named with [] -> None | ns -> Some (String.concat "; " ns)
  in
  Report.v ?detail Report.Pulled subject

let summary ?named ~remote ~pulled results =
  let again, work =
    List.partition
      (fun (_, (o : Outcome.t), _, _) -> o.word = Outcome.Landed)
      results
  in
  let word = if work = [] then Outcome.Landed else Outcome.Needs_work in
  let landings =
    List.map
      (fun ((r : replay), (o : Outcome.t), became, _) ->
        {
          Outcome.branch = r.name;
          was = r.was;
          became = (if o.word = Outcome.Landed then became else None);
        })
      results
  in
  let next =
    List.find_map
      (fun (_, (o : Outcome.t), _, restored) ->
        if o.word = Outcome.Landed then None
        else Option.map (fun b -> Fmt.str "mq land %a" Branch.pp b) restored)
      results
  in
  let needs =
    match work with
    | [] -> ""
    | [ _ ] -> " and 1 needs work"
    | w -> Fmt.str " and %d need work" (List.length w)
  in
  Fmt.kstr
    (Outcome.v ?next ~landed:(work = []) ~published:false ~landings word)
    "pulled %s from %s; of yours, %d landed again%s%s" (plural pulled "commit")
    remote (List.length again) needs
    (Option.fold ~none:"" ~some:(fun n -> "; " ^ n) named)

(* The land that takes the first of [replays] up. *)
let first_land = function
  | (r : replay) :: _ -> Fmt.kstr Option.some "mq land %a" Branch.pp r.name
  | [] -> None

let queued ?named ~remote ~pulled replays =
  let n = List.length replays in
  let next = first_land replays in
  let landings =
    List.map
      (fun (r : replay) ->
        { Outcome.branch = r.name; was = r.was; became = None })
      replays
  in
  Fmt.kstr
    (Outcome.v ?next ~landed:false ~published:false ~landings Outcome.Queued)
    "pulled %s from %s; of yours, %s queued again on the new tip%s"
    (plural pulled "commit") remote (plural n "landing")
    (Option.fold ~none:"" ~some:(fun n -> "; " ^ n) named)

(* {1 Transitions} *)

let pp_phase ppf = function
  | Reading_local -> Fmt.string ppf "reading the local branches"
  | Fetching { current = r, _; _ } -> Fmt.pf ppf "fetching %s" r
  | Reading_facts -> Fmt.string ppf "reading the branches"
  | Writing { rest; _ } ->
      Fmt.pf ppf "writing, %d writes left" (List.length rest)
  | Unpinning _ -> Fmt.string ppf "unpinning"
  | Done _ -> Fmt.string ppf "done"

let pp ppf t = Fmt.pf ppf "%s: %a" machine pp_phase t.phase

let pp_write ppf = function
  | Rescue { off; _ } -> Fmt.pf ppf "rescue %a" Branch.pp off
  | Requeue { entry; _ } -> Fmt.pf ppf "requeue %a" Branch.pp entry.name
  | Reset { branch; _ } -> Fmt.pf ppf "reset %a" Branch.pp branch
  | Seen { remote; branch; _ } ->
      Fmt.pf ppf "seen %s/%a" remote Branch.pp branch
  | Track { branch; remote } -> Fmt.pf ppf "track %s/%a" remote Branch.pp branch

let pp_action ppf = function
  | Read_local -> Fmt.string ppf "read the local branches"
  | Fetch { remote; _ } -> Fmt.pf ppf "fetch %s" remote
  | Read_facts _ -> Fmt.string ppf "read the branches"
  | Write w -> pp_write ppf w
  | Unpin { name; _ } -> Fmt.pf ppf "unpin %a" Branch.pp name
  | Journal { branch; kind } ->
      Fmt.pf ppf "journal %s for %a" (Event.kind_name kind) Branch.pp branch

let pp_event ppf = function
  | Local_read ls -> Fmt.pf ppf "%d local branches" (List.length ls)
  | Fetched { remote; _ } -> Fmt.pf ppf "fetched %s" remote
  | Unreachable { remote; why } -> Fmt.pf ppf "%s unreachable: %s" remote why
  | Unsupported { remote; why } -> Fmt.pf ppf "%s unsupported: %s" remote why
  | Untrusted { remote; why } -> Fmt.pf ppf "%s untrusted: %s" remote why
  | Facts_read fs -> Fmt.pf ppf "%d branches read" (List.length fs)
  | Written -> Fmt.string ppf "written"
  | Requeued _ -> Fmt.string ppf "requeued"
  | Lost what -> Fmt.pf ppf "lost: %s" what
  | Overwritten { checkout; _ } -> Fmt.pf ppf "%a overwritten" Fpath.pp checkout
  | Unmerged { checkout; _ } -> Fmt.pf ppf "%a in conflict" Fpath.pp checkout
  | Unpinned -> Fmt.string ppf "unpinned"
  | Signalled s -> Fmt.pf ppf "signalled %a" Signal.pp s
  | Unanswered (a, why) ->
      Fmt.pf ppf "%a: %a" pp_action a Machine.pp_unanswered why

let fetch t ~all current rest fetched =
  let remote, branches = current in
  Ok
    ( { t with phase = Fetching { all; current; rest; fetched } },
      [ Fetch { remote; branches } ] )

let on_local t locals =
  if t.request.no_wait && not t.context.scheduler then
    stop t
      (outcome ~next:"mq pull" Outcome.Refused
         "--no-wait needs a scheduler, and none is registered on this machine")
  else
    match by_remote (sources t.context t.request locals) with
    | [] ->
        stop t
          (outcome Outcome.Refused
             "Git names no remote for any branch of the DAG, and no REMOTE was \
              given: a machine with no remote has nothing to pull")
    | first :: rest as all -> fetch t ~all first rest []

let interrupted replays =
  let n = List.length replays in
  let next = first_land replays in
  outcome ?next Outcome.Interrupted
    "the pull was interrupted: %s %s queued on the new tip" (plural n "landing")
    (if n = 1 then "stays" else "stay")

let writing t (plan : plan) rest pins =
  match rest with
  | [] when t.interrupted -> stop t (interrupted plan.replays)
  | [] ->
      finish t
        (Reconciled
           {
             report = report plan;
             replays = plan.replays;
             remotes = remotes plan;
             pulled = plan.pulled;
           })
  | w :: rest ->
      Ok ({ t with phase = Writing { plan; rest; pins } }, [ Write w ])

let unpin t rest outcome =
  match rest with
  | [] -> stop t outcome
  | (name, expected) :: rest ->
      Ok
        ( { t with phase = Unpinning { current = name; rest; outcome } },
          [ Unpin { name; expected } ] )

(* A withdrawn pin's landing left the queue: its outcome is the pull's, under
   its own name (doc/invariants.md, an entry never leaves the queue without a
   journaled event naming why). *)
let withdrawn name (o : Outcome.t) =
  Journal
    {
      branch = name;
      kind =
        Event.Ended
          (Outcome.v ~branch:name o.word
             (Fmt.str "its pin is withdrawn: %s" o.detail));
    }

let on_facts t facts =
  match plan t.context facts with
  | Error o -> stop t o
  | Ok p -> writing t p p.writes []

let current_write = function
  | Writing { plan; rest; _ } ->
      let i = List.length plan.writes - List.length rest - 1 in
      List.nth_opt plan.writes i
  | _ -> None

let incoming t ~now:_ e =
  match (t.phase, e) with
  | Done _, _ -> Ok (t, [])
  | Writing _, Signalled _ -> Ok ({ t with interrupted = true }, [])
  | Unpinning _, Signalled _ -> Ok (t, [])
  | (Reading_local | Fetching _ | Reading_facts), Signalled _ ->
      stop t
        (outcome Outcome.Interrupted "the pull was interrupted: nothing moved")
  | Reading_local, Local_read locals -> on_local t locals
  | ( Fetching { all; current = remote, _; rest; fetched },
      Fetched { fetched = got; _ } ) -> (
      let fetched = fetched @ [ (remote, got) ] in
      match rest with
      | next :: rest -> fetch t ~all next rest fetched
      | [] ->
          let branches =
            List.concat_map (fun (r, bs) -> List.map (fun b -> (r, b)) bs) all
          in
          let takes =
            List.filter_map
              (fun (_, b) ->
                Option.map (fun s -> (b, s)) (Rules.takes t.context.rules b))
              branches
          in
          Ok
            ( { t with phase = Reading_facts },
              [ Read_facts { fetched; branches; takes } ] ))
  | Fetching _, Unreachable { remote; why } ->
      stop t
        (outcome Outcome.Unavailable "%s cannot be reached (%s): nothing moved"
           remote why)
  | Fetching _, (Unsupported { remote; why } | Untrusted { remote; why }) ->
      stop t (outcome Outcome.Refused "%s: %s: nothing moved" remote why)
  | Fetching { current = remote, _; _ }, Unanswered (Fetch _, why) ->
      stop t
        (outcome Outcome.Unavailable "the fetch from %s did not finish: %a"
           remote Machine.pp_unanswered why)
  | Reading_facts, Facts_read facts -> on_facts t facts
  | Writing { plan; rest; pins }, Written -> (
      (* A branch taken back holds its landings' pins: none is withdrawn
         after. *)
      match current_write t.phase with
      | Some (Reset _) -> writing t plan rest []
      | _ -> writing t plan rest pins)
  | Writing { plan; rest; pins }, Requeued id -> (
      match current_write t.phase with
      | Some (Requeue { entry; _ }) ->
          writing t plan rest ((entry.name, id) :: pins)
      | _ -> writing t plan rest pins)
  | Writing { pins; _ }, Overwritten { checkout; paths } ->
      unpin t pins
        (outcome Outcome.Removed_from_queue
           "%a holds changes taking the branch back would overwrite: %s; \
            nothing moved"
           Fpath.pp checkout (String.concat ", " paths))
  | Writing { pins; _ }, Unmerged { checkout; paths } ->
      unpin t pins
        (outcome Outcome.Removed_from_queue
           "%a has an index in conflict at %s, and the branch cannot move \
            under it; nothing moved"
           Fpath.pp checkout (String.concat ", " paths))
  | Writing { pins; _ }, Lost what -> (
      let o =
        outcome Outcome.Removed_from_queue
          "%s moved while the pull wrote: what was written stays, and mq pull \
           again reads it"
          what
      in
      (* A branch that moved before its reset keeps its landings: their
         pins go, as when a checkout refuses the move. *)
      match current_write t.phase with
      | Some (Requeue _ | Reset _) -> unpin t pins o
      | _ -> stop t o)
  | Writing _, Unanswered (Write w, why) ->
      stop t
        (outcome Outcome.Unavailable "%a could not be written: %a" pp_write w
           Machine.pp_unanswered why)
  | _, Unanswered (Journal _, _) -> Ok (t, [])
  | Unpinning { current; rest; outcome }, Unpinned -> (
      match unpin t rest outcome with
      | Ok (t, actions) -> Ok (t, withdrawn current outcome :: actions)
      | Error _ as e -> e)
  | Unpinning { rest; outcome; _ }, Unanswered (Unpin _, _) ->
      unpin t rest outcome
  | (Reading_local | Reading_facts), Unanswered (_, why) ->
      stop t
        (outcome Outcome.Unavailable "the branches could not be read: %a"
           Machine.pp_unanswered why)
  | ( (Reading_local | Fetching _ | Reading_facts | Writing _ | Unpinning _),
      ( Local_read _ | Fetched _ | Unreachable _ | Unsupported _ | Untrusted _
      | Facts_read _ | Written | Requeued _ | Lost _ | Overwritten _
      | Unmerged _ | Unpinned | Unanswered _ ) ) ->
      Machine.unexpected machine ~state:(Fmt.str "%a" pp t)
        ~event:(Fmt.str "%a" pp_event e)

let timer t ~now:_ = Ok (t, [])
let next_timeout _ = None
let ending t = match t.phase with Done e -> Some e | _ -> None
let task (_ : action) = Machine.Task.Now
let unanswered a why = Unanswered (a, why)
let signal s = Signalled s