type repository = { identity : string; name : string }

type edge = {
  consumer : string;
  dependency : string;
  path : Fpath.t;
  selected : Commit.t;
}

type selected = { repository : repository; commit : Commit.t }

type reason =
  | Missing_repository of string
  | Duplicate_repository of string
  | Cycle
  | Commit_conflict

type error = { reason : reason; paths : edge list list }
type t = { order : selected list; lags : (edge * Commit.t) list }

let order t = t.order
let lags t = t.lags

let pp_reason ppf = function
  | Missing_repository id -> Fmt.pf ppf "repository %s has no declaration" id
  | Duplicate_repository id ->
      Fmt.pf ppf "repository %s has several declarations" id
  | Cycle -> Fmt.string ppf "dependency cycle"
  | Commit_conflict -> Fmt.string ppf "dependency selected at different commits"

let pp_edge ppf e =
  Fmt.pf ppf "%s:%a -> %s@%a" e.consumer Fpath.pp e.path e.dependency Commit.pp
    e.selected

let pp_error ppf e =
  Fmt.pf ppf "%a%a" pp_reason e.reason
    (Fmt.list ~sep:Fmt.cut (fun ppf path ->
         Fmt.pf ppf " [%a]" (Fmt.list ~sep:(Fmt.any " / ") pp_edge) path))
    e.paths

let ( let* ) = Result.bind
let refuse reason paths = Error { reason; paths = List.map List.rev paths }

(* Index declarations without resolving or normalizing the caller's tokens. *)
let declarations repositories =
  let table = Hashtbl.create 16 in
  List.iter
    (fun r ->
      let previous =
        Option.value ~default:[] (Hashtbl.find_opt table r.identity)
      in
      Hashtbl.replace table r.identity (r :: previous))
    repositories;
  table

let adjacency edges =
  let table = Hashtbl.create 16 in
  List.iter
    (fun e ->
      let previous =
        Option.value ~default:[] (Hashtbl.find_opt table e.consumer)
      in
      Hashtbl.replace table e.consumer (e :: previous))
    edges;
  table

let repository table identity path =
  match Hashtbl.find_opt table identity with
  | None -> refuse (Missing_repository identity) [ path ]
  | Some [ r ] -> Ok r
  | Some _ -> refuse (Duplicate_repository identity) [ path ]

type visit = Active | Complete

(* Of two commits of one repository, keep the one that contains the other. *)
let select ~contains selections identity commit path =
  match Hashtbl.find_opt selections identity with
  | None ->
      Hashtbl.add selections identity (commit, path);
      Ok ()
  | Some (previous, _) when Commit.equal previous commit -> Ok ()
  | Some (previous, first) ->
      if contains ~repository:identity ~ancestor:previous commit then (
        Hashtbl.replace selections identity (commit, path);
        Ok ())
      else if contains ~repository:identity ~ancestor:commit previous then Ok ()
      else refuse Commit_conflict [ first; path ]

(* The reached links that select another commit than their dependency's. *)
let lagging ~reached ~selected edges =
  List.filter_map
    (fun e ->
      if not (reached e.consumer) then None
      else
        let commit = selected e.dependency in
        if Commit.equal commit e.selected then None else Some (e, commit))
    edges

(* [contains ~repository ~ancestor c] reads ancestry; the strict plan reads
   none, so any two commits of one repository conflict. *)
let plan ~contains ~root ~commit repositories edges =
  let nodes = declarations repositories in
  let links = adjacency edges in
  let states = Hashtbl.create 16 in
  let selections = Hashtbl.create 16 in
  let output = ref [] in
  let rec walk identity commit path =
    match Hashtbl.find_opt states identity with
    | Some Active -> refuse Cycle [ path ]
    | state -> (
        let* r = repository nodes identity path in
        let* () = select ~contains selections identity commit path in
        match state with
        | Some Complete -> Ok ()
        | Some Active -> assert false
        | None ->
            Hashtbl.add states identity Active;
            let children =
              List.rev
                (Option.value ~default:[] (Hashtbl.find_opt links identity))
            in
            let rec children_first = function
              | [] -> Ok ()
              | e :: rest ->
                  let* () = walk e.dependency e.selected (e :: path) in
                  children_first rest
            in
            let* () = children_first children in
            Hashtbl.replace states identity Complete;
            output := r :: !output;
            Ok ())
  in
  let* () = walk root commit [] in
  let selected identity = fst (Hashtbl.find selections identity) in
  let order =
    List.rev_map
      (fun repository -> { repository; commit = selected repository.identity })
      !output
  in
  Ok { order; lags = lagging ~reached:(Hashtbl.mem states) ~selected edges }

let v = plan ~contains:(fun ~repository:_ ~ancestor:_ _ -> false)

let equal_reason a b =
  match (a, b) with
  | Missing_repository a, Missing_repository b
  | Duplicate_repository a, Duplicate_repository b ->
      String.equal a b
  | Cycle, Cycle | Commit_conflict, Commit_conflict -> true
  | _ -> false

module type ANCESTRY = sig
  type t

  val contains : t -> repository:string -> ancestor:Commit.t -> Commit.t -> bool
end

module Make (A : ANCESTRY) = struct
  let v a = plan ~contains:(A.contains a)
end

type lane = {
  name : Branch.t;
  tip : Commit.t;
  queued : bool;
  candidate : Commit.t option;
}

type landed = { name : Branch.t; queued : Commit.t; landed : Commit.t }
type port = Held | Landed of landed | Gated of lane | Unbrought

(* The lane at [c], by its tip or its published candidate: of two, the
   queued one is the half. *)
let lane_at lanes c =
  let at =
    List.filter
      (fun (l : lane) ->
        Commit.equal l.tip c
        || Option.fold ~none:false ~some:(Commit.equal c) l.candidate)
      lanes
  in
  match List.find_opt (fun (l : lane) -> l.queued) at with
  | Some _ as l -> l
  | None -> ( match at with l :: _ -> Some l | [] -> None)

(* The landings are oldest first, as the dependency's records list them: the
   newest queued at [c] landed it; else the lane at [c]; else the newest
   whose queued tip holds [c] landed it as a replay, so [c]'s changes are in
   the commit it landed as. [contains] walks the graph, so it is asked only
   of a commit nothing else names. *)
let port ~holds ~contains ~lanes ~landings c =
  let newest p = List.find_opt p (List.rev landings) in
  let landed p = Option.map (fun l -> Landed l) (newest p) in
  if holds then Held
  else
    match landed (fun (l : landed) -> Commit.equal l.queued c) with
    | Some p -> p
    | None -> (
        match lane_at lanes c with
        | Some l -> Gated l
        | None ->
            Option.value ~default:Unbrought
              (landed (fun (l : landed) -> contains c l.queued)))

(* A landing that left [c] as it was moved none of it. Of the others, the
   oldest queued at [c], else the oldest whose queued tip holds [c], landed
   [c]'s changes first, and a later landing queued at the commit it landed
   as, such as a pull's replay of it, carried them on. Each landing is
   followed once. *)
let rec replayed ~contains ~landings c =
  let moved p (l : landed) = p l && not (Commit.equal l.landed c) in
  let first =
    match List.find_opt (moved (fun l -> Commit.equal l.queued c)) landings with
    | Some _ as l -> l
    | None -> List.find_opt (moved (fun l -> contains c l.queued)) landings
  in
  match first with
  | None -> c
  | Some l ->
      replayed ~contains
        ~landings:(List.filter (fun x -> x != l) landings)
        l.landed

let pp_port ppf = function
  | Held -> Fmt.string ppf "held"
  | Landed l ->
      Fmt.pf ppf "%a landed as %s" Branch.pp l.name (Commit.short l.landed)
  | Gated l ->
      Fmt.pf ppf "%a at %s%s" Branch.pp l.name (Commit.short l.tip)
        (match l.candidate with
        | Some c -> Fmt.str ", replayed as %s" (Commit.short c)
        | None -> if l.queued then ", queued" else ", not queued")
  | Unbrought -> Fmt.string ppf "brought by no branch"

type member = {
  id : string;
  source : Commit.t option;
  target : Commit.t option;
  serves : bool;
  tree : Tree.t option;
  checks : Check.t list;
  scripts : (Check.name * string) list;
  notes : Note.t list;
  inputs : (string * string) list;
}

type serving = { members : string list; paired : string list }
type verdict = Passed | Failed of Check.name | Unchecked of Check.name

let pp_serving ppf t = Fmt.(list ~sep:comma string) ppf t.members

let lagging r =
  r.serves
  &&
  match (r.source, r.target) with
  | Some s, Some t -> not (Commit.equal s t)
  | Some _, None -> true
  | None, _ -> false

let member_of rs id =
  List.find_opt (fun (r : member) -> String.equal r.id id) rs

(* The commit [r]'s check reads of the input at [path], as the serve reads
   it (Check.branches): [head] for the repository it names, else the input's
   source, else its target. *)
let read_of ?head rs r path =
  match List.assoc_opt path r.inputs with
  | None -> None
  | Some id -> (
      match (member_of rs id, head) with
      | None, _ -> None
      | Some _, Some (h, c) when String.equal h id -> Some c
      | Some q, _ -> (
          match q.source with Some _ as c -> c | None -> q.target))

(* The newest decided result of [c] on [r]'s tree under [config]: the
   decided note that ended last, the later of two that ended at once. *)
let decided (r : member) (c : Check.t) config =
  match r.tree with
  | None -> None
  | Some tree ->
      Option.map snd
        (List.fold_left
           (fun acc (n : Note.t) ->
             if
               Check.equal_name n.check c.name
               && Tree.equal n.tree tree
               && Build_config.equal n.config config
             then
               match (n.result, acc) with
               | ( (Check.Inherited | Check.Stuck | Check.Error | Check.Stopped),
                   _ ) ->
                   acc
               | _, Some (at, _) when Ptime.is_later at ~than:n.at -> acc
               | ((Check.Passed | Check.Failed) as res), _ -> Some (n.at, res)
             else acc)
           None r.notes)

let verdict ?head rs r =
  List.fold_left
    (fun acc (c : Check.t) ->
      match acc with
      | Failed _ -> acc
      | Passed | Unchecked _ -> (
          let inputs =
            List.map
              (fun (i : Check.input) -> (i.input, read_of ?head rs r i.path))
              c.inputs
          in
          let config =
            Build_config.v ?script:(List.assoc_opt c.name r.scripts) ~inputs c
          in
          match (decided r c config, acc) with
          | Some Check.Failed, _ -> Failed c.name
          | Some _, acc -> acc
          | None, Passed -> Unchecked c.name
          | None, acc -> acc))
    Passed r.checks

(* The identities [from] reaches along [next], [from] included. *)
let reach ~next from =
  let rec go seen = function
    | [] -> seen
    | id :: rest ->
        if List.mem id seen then go seen rest
        else go (id :: seen) (next id @ rest)
  in
  go [] [ from ]

let serving ~self rs =
  match member_of rs self with
  | None -> None
  | Some s when not (lagging s) -> None
  | Some s -> (
      let lagging id =
        match member_of rs id with Some q -> lagging q | None -> false
      in
      let reads id =
        match member_of rs id with
        | Some q -> List.filter lagging (List.map snd q.inputs)
        | None -> []
      in
      let read_by id =
        List.filter_map
          (fun q ->
            if lagging q.id && List.mem id (List.map snd q.inputs) then
              Some q.id
            else None)
          rs
      in
      let forward = reach ~next:reads self
      and backward = reach ~next:read_by self in
      let others =
        List.filter_map
          (fun q ->
            if
              (not (String.equal q.id self))
              && List.mem q.id forward && List.mem q.id backward
            then Some q.id
            else None)
          rs
      in
      match others with
      | [] -> None
      | _ ->
          let members = self :: others in
          let red id =
            match member_of rs id with
            | Some q -> (
                match verdict rs q with Failed _ -> true | _ -> false)
            | None -> false
          in
          if List.exists red members then None
          else
            let paired =
              List.sort_uniq String.compare
                (List.filter_map
                   (fun (path, id) ->
                     if List.mem id others then Some path else None)
                   s.inputs)
            in
            Some { members; paired })

type half = {
  consumer : string;
  name : Branch.t;
  queued : bool;
  candidate : Commit.t option;
  locks : Commit.t option;
  landed : bool;
}

type set = {
  ports : (string * Branch.t * port) list;
  half : half option;
  serve : serve option;
}

and serve = {
  self : string;
  read : (string * Commit.t option) list;
  members : member list;
}

type gate = Move | Wait of string

let waits fmt = Fmt.kstr (fun s -> Some s) fmt

(* What a port waits for: every commit the candidate's lock names that the
   dependency's paired branch lacks, since a target never holds a lock its
   dependency's paired branch lacks (doc/invariants.md, 11). A lane not
   landed yet moves first; a commit a lane landed, or one no branch brings,
   is locked again by the land's next replay, at the commit the lane landed
   as or at the paired branch's tip. *)
let port_waits (path, branch, port) =
  match port with
  | Gated { name; candidate = Some c; _ } ->
      waits "waits for %s's %a, replayed as %s, to land into its %a" path
        Branch.pp name (Commit.short c) Branch.pp branch
  | Gated { name; candidate = None; _ } ->
      waits "waits for %s's %a to be replayed onto its %a" path Branch.pp name
        Branch.pp branch
  | Landed { name; landed; _ } ->
      waits "waits to lock %s's %a as it landed into its %a, %s" path Branch.pp
        name Branch.pp branch (Commit.short landed)
  | Unbrought ->
      waits "waits to lock what %s's %a holds: no branch brings what it locks"
        path Branch.pp branch
  | Held -> None

(* A consumer's half not queued that landed, its lock naming a commit of
   this repository its target lacks, waits for this lane: the lane waits for
   no more of it. *)
let half_waits ~candidate (h : half) =
  let who = Fmt.str "%s's %a" h.consumer Branch.pp h.name in
  if not h.queued then
    if h.landed then None else waits "waits for %s, which is not queued" who
  else
    match (h.candidate, h.locks) with
    | Some _, Some c when Commit.equal c candidate -> None
    | Some _, Some c ->
        waits "waits for %s, which passed with %s, to pass with %s" who
          (Commit.short c) (Commit.short candidate)
    | None, _ | Some _, None -> waits "waits for %s to pass with it" who

(* What a serve of a set waits for: the inputs it read whose member neither
   holds what it read nor passed there. *)
let serve_waits ~candidate (v : serve) =
  let ours =
    match member_of v.members v.self with Some s -> s.inputs | None -> []
  in
  let stands (path, c) =
    match Option.bind (List.assoc_opt path ours) (member_of v.members) with
    | None -> false
    | Some q ->
        Option.equal Commit.equal q.target c
        || Option.equal Commit.equal q.source c
           && verdict ~head:(v.self, candidate) v.members q = Passed
  in
  match List.filter (fun r -> not (stands r)) v.read with
  | [] -> None
  | missing ->
      waits "waits for %a to pass there or to land"
        Fmt.(
          list ~sep:comma (fun ppf (path, c) ->
              match c with
              | Some c -> pf ppf "%s at %a" path Commit.pp c
              | None -> pf ppf "%s, which has no source" path))
        missing

let gate ~candidate s =
  let first =
    match List.find_map port_waits s.ports with
    | Some _ as w -> w
    | None -> (
        match Option.bind s.half (half_waits ~candidate) with
        | Some _ as w -> w
        | None -> Option.bind s.serve (serve_waits ~candidate))
  in
  match first with Some why -> Wait why | None -> Move