Source file BuildRebuilders.ml

(** An OCaml embedding of rebuilders described in "Build systems à la carte:
    Theory and practice".

    This embedding is not necessary for MlFront thunks; we can implement thunks
    without using a generalized framework! However, this embedding may aid
    modifications to thunk implementations.

    Confer
    {{:https://www.cambridge.org/core/services/aop-cambridge-core/content/view/097CE52C750E69BD16B78C318754C7A4/S0956796820000088a.pdf/build-systems-a-la-carte-theory-and-practice.pdf}5
     Rebuilders}.

    {v
Andrey Mokhov, Neil Mitchell, and Simon Peyton Jones. 2018. Build Systems à la Carte. Proc. ACM Program. Lang. 2, ICFP, Article 79 (September 2018) 
doi:10.1017/S0956796820000088
    v} *)

(** The type of synchronous rebuilder build system components. *)
module type REBUILDER = sig
  type vc
  (** The type of applicative/monad-constrained build task value. *)

  type ir
  (** The type of persistent build information carried by a state monad.

      The state can be combined with persistent build information from a
      {!SCHEDULER} to make the full persistent build information. *)

  type k
  (** The type of build task key. *)

  type v
  (** The type of build task value. *)

  type o
  (** The type of build task origin. *)

  type tracked
  (** The type of what is being tracked for a build task value. *)

  type lifted_vc
  type task = k * ((o -> k -> vc) -> vc)
  type rebuilt_vc = ir -> v * ir * tracked
  type rebuilt_task = k * ((o -> k -> rebuilt_vc) -> rebuilt_vc)

  type t = ir -> o -> v -> task -> rebuilt_task
  (** The type of rebuilders which take an information recaller [ir], an origin
      [o], a value [v], and a task [task] to produce a rebuilt task. *)
end

let rebuilder_async_cls =
  BuildConstraints.StateMessage.new_class_exn
    "MlFront_Thunk.BuildRebuilders.CtRebuilderAsync"

(** The type of asynchronous rebuilder build system components. *)
module type REBUILDER_ASYNC = sig
  type vc
  (** The type of applicative/monad-constrained build task value. *)

  type ir
  (** The type of persistent build information carried by a state monad.

      The state can be combined with persistent build information from a
      {!SCHEDULER} to make the full persistent build information. *)

  type k
  (** The type of build task key. *)

  type v
  (** The type of build task value. *)

  type o
  (** The type of build task origin. *)

  type state

  type tracked
  (** The type of what is being tracked for a build task value. *)

  type 'a promise
  type journal
  type journal_entry_id
  type journal_entry_value
  type task = k * ((o -> k -> vc) -> vc)
  type ('k, 'v) key_dependent_hash

  type rebuilt_vc =
    (state * journal ->
    (v
    * BuildConstraints.StateMessage.t list
    * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
    promise)
    promise

  type rebuilt_task = k * ((o -> k -> rebuilt_vc) -> rebuilt_vc)

  type t = ir -> o -> v -> task -> rebuilt_task
  (** The type of rebuilders which take an information recaller [ir], an origin
      [o], a value [v], and a task [task] to produce a rebuilt task. *)

  type BuildConstraints.StateMessage.obj +=
    | PostBuildValueAndDependencyHashes of
        (k * (k, v) key_dependent_hash option) list * v
end

(** Functions common to async and sync constructive trace rebuilders. *)
module CtRebuilderUtils
    (K : BuildSystems.ABSTRACT_TYPE)
    (V : BuildSystems.ABSTRACT_TYPE)
    (CT : BuildSystems.CLOUD_PERSISTENT_HASH with type k = K.t and type v = V.t) =
struct
  (** [is_elem k v list_of_v] is [true] if and only if the key [k] dependent
      value [v] is a member of the value list [list_of_v].

      Membership is considered using the hash of the value. This is the source
      of the {!BuildSystems.CLOUD_PERSISTENT_HASH} technical requirement that
      the hash {b must be a secure hash} so that hash equality means value
      equality. *)
  let is_elem (k : K.t) (v : V.t) (vl : V.t list) =
    match CT.maybe_cloud_persistent_hash k v with
    | None -> false
    | Some h ->
        List.exists
          (fun v' ->
            match CT.maybe_cloud_persistent_hash k v' with
            | None -> false
            | Some h' -> CT.strong_hash_equal h h')
          vl
end

(** Constructive trace rebuilder.

    [CT] is the functor parameter for the constructive trace store. Its hash
    function {b must be a "secure hash" like SHA-256} in that two values can be
    considered equal if their (secure) hashes are equal.
    {b Do not use conventional hashes} like OCaml's {!Stdlib.Hashtbl.hash} or a
    MD5 hash which do not imply that hash equality is the same as value
    equality.*)
module CtRebuilder
    (IR : BuildSystems.ABSTRACT_TYPE)
    (K : BuildSystems.ABSTRACT_TYPE)
    (V : BuildSystems.ABSTRACT_TYPE)
    (O : BuildSystems.ORIGIN_WITH_DEPTH with type k = K.t)
    (C :
      BuildConstraints.MONAD_STATE_WRITER
        with type state = IR.t
         and type output = (K.t * V.t) list)
    (CT :
      BuildTraces.CONSTRUCTIVE_TRACE_STORE_SYNC
        with type k = K.t
         and type v = V.t
         and type ir = IR.t
         and module C = C)
    (Tasks :
      BuildSystems.TASKS
        with type k = K.t
         and type vc = V.t C.t
         and type lifted_vc = V.t C.t
         and type o = O.t) : sig
  include
    REBUILDER
      with type k = K.t
       and type ir = IR.t
       and type v = V.t
       and type vc = V.t C.t
       and type o = O.t
       and type tracked = (K.t * V.t) list

  val rebuilder :
    ir ->
    o ->
    v ->
    k * ((o -> k -> v C.t) -> v C.t) ->
    k * ((o -> k -> rebuilt_vc) -> rebuilt_vc)
end = struct
  open CtRebuilderUtils (K) (V) (CT)

  type k = K.t
  type ir = IR.t
  type v = V.t
  type vc = V.t C.t
  type lifted_vc = vc
  type o = O.t
  type tracked = (K.t * V.t) list
  type task = k * ((o -> k -> vc) -> vc)
  type rebuilt_vc = ir -> v * ir * tracked
  type rebuilt_task = k * ((o -> k -> rebuilt_vc) -> rebuilt_vc)
  type t = ir -> o -> v -> task -> rebuilt_task

  module Tracked = BuildSystems.TrackOnStateWriter (K) (V) (O) (C)

  let rebuilder : t =
   fun (ir : ir) (origin : O.t) (v : V.t)
       ((k, _f_compute) as task : Tasks.task) ->
    (* make rebuilder *)
    ( k,
      fun (fetch : o -> k -> rebuilt_vc) : rebuilt_vc ->
        let open BuildConstraints.MonadLetSyntax (C) in
        let* cached_values =
          let tracked_fetch_hash dep_k : v C.t = fetch origin dep_k in
          CT.construct_ct k
            (fun dep_k ->
              C.map
                (fun dep_v -> CT.maybe_cloud_persistent_hash dep_k dep_v)
                (tracked_fetch_hash dep_k))
            ir
        in
        match cached_values with
        | _ when is_elem k v cached_values -> C.pure v
        | cached_value :: _ -> C.pure cached_value
        | [] ->
            let new_value, deps =
              Tracked.track ir (module Tasks) origin task fetch
            in
            let ir_modification =
              CT.record_ct k v
                (List.map
                   (fun (dep_k, dep_v) ->
                     (dep_k, CT.maybe_cloud_persistent_hash dep_k dep_v))
                   deps)
            in
            let* () = C.modify ir_modification in
            C.return new_value )
end

(** Can listen and react to rebuilder events. *)
module type REBUILDER_EVENTS = sig
  type k
  type v
  type uc
  type o

  val on_dependency_discovered : depth:int -> key:k -> depends_upon_key:k -> uc
  (** [on_dependency_discovered ~depth ~key ~depends_upon_key] is the event that
      the build task [key] has discovered a dependency on the build task
      [depends_upon_key].

      The [depth] is how deep in the dependency chain the discovery is. A depth
      of [0] means that [key] is being built directly by the user (or top-level
      build system).

      Returns a unit continuation. *)

  val before_rebuild_key : candidate_values:v list -> origin:o -> k -> uc
  (** [before_rebuild_key ~candidate_values ~origin k] is the event that the key
      [k] is out-of-date and about to be built so it is up-to-date.

      The [candidate_values] are values that were considered for [k] from the
      constructive trace store, but none matched the values available in the
      value store.

      [origin] is the origin of the build task.

      Returns a unit continuation. *)
end

(** Asynchronous constructive trace rebuilder.

    [CT] is the functor paramter for the constructive trace store. Its hash
    function {b must be a "secure hash" like SHA-256} in that two values can be
    considered equal if their (secure) hashes are equal.
    {b Do not use conventional hashes} like OCaml's {!Stdlib.Hashtbl.hash} or a
    MD5 hash which do not imply that hash equality is the same as value
    equality.*)
module CtRebuilderAsync
    (IR : BuildSystems.ABSTRACT_TYPE)
    (K : sig
      type t

      val show : t -> string [@@warning "-unused-value-declaration"]
    end)
    (O : BuildSystems.ORIGIN_WITH_DEPTH with type k = K.t)
    (V : sig
      type t

      val with_origin : t -> O.t -> t
      val show : t -> string [@@warning "-unused-value-declaration"]
    end)
    (P : BuildConstraints.PROMISE_IMPL)
    (C :
      BuildConstraints.MONAD_STATE_WRITER_ASYNC
        with type state = IR.t
         and type 'a promise = 'a P.promise)
    (RE :
      REBUILDER_EVENTS
        with type k = K.t
         and type v = V.t
         and type uc = unit C.t
         and type o = O.t)
    (CT :
      BuildTraces.CONSTRUCTIVE_TRACE_STORE_ASYNC
        with type k = K.t
         and type v = V.t
         and type ir = IR.t
         and module C = C)
    (Tasks :
      BuildSystems.TASKS
        with type k = K.t
         and type vc = V.t C.t
         and type lifted_vc = V.t C.t
         and type o = O.t) : sig
  include
    REBUILDER_ASYNC
      with type k = K.t
       and type ir = IR.t
       and type v = V.t
       and type vc = V.t C.t
       and type o = O.t
       and type state = C.state
       and type tracked = (K.t * (K.t, V.t) CT.key_dependent_hash) list * V.t
       and type 'a promise = 'a P.promise
       and type journal = C.journal
       and type journal_entry_id = C.journal_entry_id
       and type journal_entry_value = C.journal_entry_value

  val rebuilder :
    ir ->
    o ->
    v ->
    k * ((o -> k -> v C.t) -> v C.t) ->
    k * ((o -> k -> rebuilt_vc) -> rebuilt_vc)
end = struct
  open CtRebuilderUtils (K) (V) (CT)

  type BuildConstraints.StateMessage.obj +=
    | PostBuildValueAndDependencyHashes of
        (K.t * (K.t, V.t) CT.key_dependent_hash option) list * V.t

  type k = K.t
  type ir = IR.t
  type v = V.t
  type vc = V.t C.t
  type o = O.t
  type state = C.state
  type tracked = (K.t * (K.t, V.t) CT.key_dependent_hash) list * V.t
  type 'a promise = 'a P.promise
  type journal = C.journal
  type journal_entry_id = C.journal_entry_id
  type journal_entry_value = C.journal_entry_value
  type task = k * ((o -> k -> vc) -> vc)
  type ('k, 'v) key_dependent_hash = (k, v) CT.key_dependent_hash

  type rebuilt_vc =
    (C.state * C.journal ->
    (v
    * BuildConstraints.StateMessage.t list
    * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
    promise)
    promise

  type rebuilt_task = k * ((o -> k -> rebuilt_vc) -> rebuilt_vc)
  type t = ir -> o -> v -> task -> rebuilt_task

  module M = struct
    type ('key, 'value) t = BuildConstraints.StateMessage.t

    let dependency_discovered ~depth ~key ~depends_upon_key =
      RE.on_dependency_discovered ~depth ~key ~depends_upon_key

    let message_of_build_result ~deps ~result =
      let dep_hashes =
        List.map (fun (k, v) -> (k, CT.maybe_cloud_persistent_hash k v)) deps
      in
      BuildConstraints.StateMessage.create rebuilder_async_cls
        (PostBuildValueAndDependencyHashes (dep_hashes, result))
  end

  module Tracked = BuildSystems.TrackOnStateWriterAsync (K) (V) (O) (P) (C) (M)

  let rebuilder : t =
   fun (ir : ir) (o : O.t) (v : V.t) ((k, f_compute) : Tasks.task) ->
    ( k,
      fun (fetch : o -> k -> rebuilt_vc) : rebuilt_vc ->
        let open BuildConstraints.MonadLetSyntax (C) in
        (* Printf.eprintf "rebuilder k=%s child_o=%s before construct_ct\n"
          (K.show k) (O.show child_o); *)
        let* cached_values =
          let tracked_fetch_hash (dep_k : k) : v C.t = fetch o dep_k in
          CT.construct_ct k
            (fun dep_k ->
              C.map
                (fun dep_v -> CT.maybe_cloud_persistent_hash dep_k dep_v)
                (tracked_fetch_hash dep_k))
            ir
        in
        (* Printf.eprintf
          "rebuilder k=%s child_o=%s cached_values(construct_ct)=%d \
           maybe_cloud_persistent_hashes:%s\n"
          (K.show k) (O.show child_o)
          (List.length cached_values)
          (String.concat "|"
             (List.map
                (fun v ->
                  match CT.maybe_cloud_persistent_hash k v with
                  | None -> "none"
                  | Some h -> CT.strong_hash_show h)
                cached_values)); *)
        let ( let*+ ) = P.bind_promise in
        match cached_values with
        | _ when is_elem k v cached_values -> C.pure v
        | cached_value :: _ -> C.pure cached_value
        | [] ->
            let* () =
              (* Printf.eprintf
                "rebuilder before_rebuild_key |1 k=%s | origin=%s\n" (K.show k)
                (O.show o); *)
              RE.before_rebuild_key ~candidate_values:cached_values ~origin:o k
            in
            let*+ msg =
              Tracked.track ir
                (module Tasks)
                o (k, f_compute)
                (fun o' k_dep -> fetch o' k_dep)
            in
            let deps, new_value =
              match
                BuildConstraints.StateMessage.downcast msg rebuilder_async_cls
              with
              | Some (PostBuildValueAndDependencyHashes (dep_hashes, result)) ->
                  (dep_hashes, result)
              | _ ->
                  Printf.ksprintf failwith
                    "Expected PostBuildValueAndDependencyHashes, not %s"
                    (BuildConstraints.StateMessage.show msg)
            in
            (* rewrite value to include the now accurate origin *)
            let new_value = V.with_origin new_value o in
            (* Printf.eprintf "rebuilder k=%s after track new_value=%s\n"
              (K.show k) (V.show new_value); *)
            (* Printf.eprintf "post_record_ct k=%s\n" (K.show k); *)
            let* () = CT.post_record_ct k new_value deps ir in
            C.return new_value )
end