Source file CodeptConstructs.ml

(** [CodeptConstructs] are modules and functions that are essential to running
    a sequence of codept solves. *)

module Private = struct
  module M = Module
  module Nms = Namespaced
  module Envt' = Envt.Core

  let count_pending_extension_insensitive (pending : 'a Solver.i list) =
    let map =
      List.fold_left
        (fun map { Solver.input; _ } ->
          let path_noext =
            Filename.remove_extension (Namespaced.filepath input.path)
          in
          Astring.String.Map.add path_noext () map)
        Astring.String.Map.empty pending
    in
    Astring.String.Map.bindings map |> List.length

  let pp_resolved fmt v =
    Fmt.Dump.(list (pair Pkg.pp DerivUnit.Extras.unit_pp))
      fmt (Pkg.Map.bindings v)

  let pp_slow_solver_i ~pp_code fmt { Solver.input; code } =
    Fmt.pf fmt "@[<hov 2>input.src=%a@;input=%a@;ongoing=%a@]" DerivPkg.pp
      input.src DerivUnit.Extras.unit_pp_input input pp_code code

  (* We want two Pkg.t to be different if they have different file extensions. *)
  let compare_solver_i { Solver.input = input1; _ } { Solver.input = input2; _ }
      =
    DerivPkg.Distinct.compare input1.src input2.src

  let pp_slow_diff_state ~pp_code ~eq_env ~resolved_f ~pending_f ~postponed_f
      fmt (state, old_state) =
    let pp_solver_i = pp_slow_solver_i ~pp_code in
    let pp_pending = Fmt.list ~sep:(Fmt.sps 0) pp_solver_i in
    let in_l1_not_l2 ~compare l1 l2 =
      List.filter
        (fun x1 -> not @@ List.exists (fun x2 -> compare x1 x2 = 0) l2)
        l1
    in
    let in_l2_not_l1 ~compare l1 l2 =
      List.filter
        (fun x2 -> not @@ List.exists (fun x1 -> compare x1 x2 = 0) l1)
        l2
    in
    let same_resolved, structurally_same_resolved =
      match old_state with
      | Some g when resolved_f state = resolved_f g -> (true, true)
      | Some g
        when Fmt.str "%a" pp_resolved (resolved_f state)
             = Fmt.str "%a" pp_resolved (resolved_f g) ->
          (true, false)
      | _ -> (false, false)
    in
    let same_pending, new_in_pending, removed_from_pending =
      match old_state with
      | Some g when pending_f state = pending_f g -> (true, [], [])
      | Some g
        when Fmt.str "%a" pp_pending (pending_f state)
             = Fmt.str "%a" pp_pending (pending_f g) ->
          (true, [], [])
      | Some g ->
          ( false,
            in_l1_not_l2 ~compare:compare_solver_i (pending_f state)
              (pending_f g),
            in_l2_not_l1 ~compare:compare_solver_i (pending_f state)
              (pending_f g) )
      | _ -> (false, [], [])
    in
    let same_postponed =
      match old_state with
      | Some g when postponed_f state = postponed_f g -> true
      | _ -> false
    in
    let same_env =
      match old_state with Some g when eq_env state g -> true | _ -> false
    in
    let pp_opt msg ppf fmt v =
      match v with
      | None -> Format.pp_print_string fmt msg
      | Some v -> ppf fmt v
    in
    Fmt.pf fmt
      "@[<v>---:------:--- structurally same 'resolved'? %b.@;\
       ---:------:--- same 'env'? %b.@;\
       @[<hov 2>---:-diff-:--- newly in 'pending'=@;\
       %a@]@;\
       @[<hov 2>---:-diff-:--- no longer in 'pending'=@;\
       %a@]@;\
       @[<hov 2>---:-full-:--- 'pending'=@;\
       %a@]@;\
       @[<hov 2>---:-full-:--- 'postponed'=@;\
       %a@]@;\
       @[<hov 2>---:-full-:--- 'resolved'=@;\
       %a@]@]"
      structurally_same_resolved same_env
      (Fmt.Dump.list pp_solver_i)
      new_in_pending
      (Fmt.Dump.list pp_solver_i)
      removed_from_pending
      (pp_opt "<same>" pp_pending)
      (if same_pending then None else Some (pending_f state))
      (pp_opt "<same>" (Fmt.Dump.list DerivUnit.Extras.unit_pp_input))
      (if same_postponed then None else Some (postponed_f state))
      (pp_opt "<same>" pp_resolved)
      (if same_resolved then None else Some (resolved_f state))

  let src_of_i { Solver.input; _ } = input.src

  let find_dup pending =
    (* this is O(n^2). you can do better! *)
    List.fold_left
      (fun acc i ->
        match acc with
        | Some v -> Some v
        | None -> (
            let src = src_of_i i in
            match
              List.find_all
                (fun i' -> DerivPkg.Distinct.compare src (src_of_i i') == 0)
                pending
            with
            | [] ->
                (* self-joining must have at least one intersection *)
                assert false
            | [ _found_self_once ] -> acc
            | dup :: dup2 :: _ -> Some (dup, dup2)))
      None pending
end

module Make (StageParam : Stage.param) = struct
  open Private
  module Engine = Dep_zipper.Make (Envt') (StageParam)
  module S = Solver.Make (Envt') (StageParam) (Engine)

  (* Handy simplifier for diffing states *)
  let pp_diff_state =
    pp_slow_diff_state ~pp_code:Engine.pp
      ~eq_env:(fun state1 state2 -> Envt'.eq state1.S.env state2.S.env)
      ~resolved_f:(fun state -> state.S.resolved)
      ~pending_f:(fun state -> state.S.pending)
      ~postponed_f:(fun state -> state.S.postponed)

  let add_if_not_present (type a) ~(mem : a -> a list -> bool) (l : a list)
      (x : a) =
    if mem x l then l else x :: l

  (* ....   Merge is on the [input.src] field (ex. Y:\source\DkHelloScript\src\DkHelloScript_Std\Y33ArticleX\Doc.mli)
     ....   not [input.path] (ex. DkHelloScript_Std__Y33ArticleX__Doc) *)
  let mem_pending pending =
    let map =
      List.map (fun ({ Solver.input; _ } as i) -> (input.src, i)) pending
      |> List.to_seq |> Pkg.Map.of_seq
    in
    fun x -> Pkg.Map.mem x map

  let merge_state (s : S.state) (incremental : S.state) (new_env : Envt'.t) :
      S.state * bool =
    let mem_incr_pending = mem_pending incremental.pending in
    let s' =
      {
        s with
        env = new_env;
        pending =
          List.fold_left
            (fun incr_acc_vs (old_v : Engine.on_going Solver.i) ->
              if mem_incr_pending old_v.input.src then incr_acc_vs
              else old_v :: incr_acc_vs)
            incremental.pending s.pending;
        postponed =
          List.fold_left
            (add_if_not_present ~mem:List.mem)
            incremental.postponed s.postponed;
      }
    in
    let changed =
      List.length s'.pending <> List.length s.pending
      || List.length s'.postponed <> List.length s.postponed
      || not (Envt'.eq s'.env s.env)
    in
    (s', changed)

  let invariant_check ~try_quietly ~zero ~debug (s1 : S.state) (s0 : S.state) =
    (* Never have repeats in pending *)
    let ( let* ) = Result.bind in
    let* () =
      let dolog f dup dup2 =
        f
          ("%a was duplicated in pending:@;CONFLICTING 1@;%a@;CONFLICTING 2@;%a"
            : _ format4)
          Pkg.pp (src_of_i dup)
          (pp_slow_solver_i ~pp_code:Engine.pp)
          dup
          (pp_slow_solver_i ~pp_code:Engine.pp)
          dup2
      in
      match (find_dup s1.pending, Logs.level ()) with
      | None, _ -> Ok ()
      | Some (dup, dup2), Some Debug ->
          debug (fun l -> dolog (l ?header:None ?tags:None) dup dup2);
          zero
            ~msg:
              (Fmt.str
                 "%a was duplicated in pending.@ The debug logs contain the \
                  duplication."
                 Pkg.pp (src_of_i dup))
            ()
      | Some (dup, dup2), _ -> Error (`Msg (dolog Fmt.str dup dup2))
    in

    (* Never have an item in pending and resolved simultaneously *)
    let ps = Pkg.Set.of_list (List.map src_of_i s1.pending) in
    let rs = Pkg.Set.of_list (List.map fst (Pkg.Map.bindings s1.resolved)) in
    let simultaneously = Pkg.Set.inter ps rs |> Pkg.Set.to_seq |> List.of_seq in
    if simultaneously <> [] then
      zero
        ~msg:
          (Fmt.str "%a@ was simultaneously in pending and resolved"
             (Fmt.Dump.list Pkg.pp) simultaneously)
        ()
    else if try_quietly then
      (* [S.approx_and_try_harder] will ...
         Add approximation to make cycle resolvable, possibly adding
         spurious dependencies.
         Drop intermediary units that are deemed non-resolvable

         That "Drop intermediary units" means the universe may not be
         growing! *)
      Ok ()
    else
      (* Do this math right! When a pair of mli/ml is resolved,
         two items are removed from pending and one is placed into
         resolved. *)
      let p1 = count_pending_extension_insensitive s1.pending in
      let p0 = count_pending_extension_insensitive s0.pending in
      let r1 = List.length (Pkg.Map.bindings s1.resolved) in
      let r0 = List.length (Pkg.Map.bindings s0.resolved) in
      if p1 + r1 < p0 + r0 then (
        Fmt.epr "@[<hov 2>The universe was not growing.@;%a@]@." pp_diff_state
          (s1, Some s0);
        let msg =
          Fmt.str
            "@[<v>@[Universe is not growing!@]@;\
             @[There are %d units@ in 'pending'@ (modulo file extensions)@ \
             when before there were %d units.@]@;\
             @[There are %d units@ in 'resolved'@ (modulo file extensions)@ \
             when before there were %d units.@]@;\
             @[The standard error contains@ the state difference.@]@]" p1 p0 r1
            r0
        in
        zero ~msg ())
      else Ok ()
end