Source file BuildConstraints.ml

(** An OCaml embedding of functors, applicatives and monads 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}3.4
     The need for polymorphism in task}, although we abandon Haskell-style
    polymorphism in OCaml since we can use a distinct module functor (with
    distinct applicative/monad) for each build system.

    {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} *)

module type FUNCTOR = sig
  type 'a t

  val map : ('a -> 'b) -> 'a t -> 'b t

  (* We didn't add [mapConst] since it is an optimization and it is subsumed by [pure] in PURE_SEQ
       when we restrict ourselves to Applicatives and Monads.
       Confer https://lean-lang.org/doc/reference/4.19.0/Functors___-Monads-and--do--Notation/ *)
end

module type MONOID = sig
  type t

  val identity : t
  (** [identity] is the monoid identity value where the equalities
      [identity • a = a] and [a • identity = a] hold. *)

  val mappend : t -> t -> t
  (** [mappend a b] is the monoid binary operation [•] where the associativity
      equation [(a • b) • c = a • (b • c)] holds. *)
end

(** A set of [Pure], [Functor], [SeqLeft], and [SeqRight] operations that are
    common to Applicative Functors and Monads.

    You should prefer the operations that are specific to Applicative Functors
    in {!APPLICATIVE} or the operations specific to Monads in {!MONAD}.

    Confer
    {{:https://lean-lang.org/doc/reference/4.19.0/Functors___-Monads-and--do--Notation}Functors,
     Monads and do-Notation}*)
module type PURE_SEQ = sig
  include FUNCTOR

  val pure : 'a -> 'a t
  val seq : ('a -> 'b) t -> (unit -> 'a t) -> 'b t
  val seq_left : 'a t -> (unit -> 'b t) -> 'a t
  val seq_right : 'a t -> (unit -> 'b t) -> 'b t
end

module PureSeqSyntax (PS : PURE_SEQ) = struct
  (* Symbols from https://lean-lang.org/doc/reference/4.19.0/Functors___-Monads-and--do--Notation *)

  let ( <$> ) = PS.map
  let ( <*> ) x f = PS.seq f x
  let ( <* ) x f = PS.seq_left f x
  let ( *> ) x f = PS.seq_right f x
end

(** {1 Applicatives} *)

module type APPLICATIVE = sig
  include FUNCTOR

  val pure : 'a -> 'a t
  val apply : ('a -> 'b) t -> 'a t -> 'b t
end

module ApplicativeSyntax (F : APPLICATIVE) = struct
  (* Symbols from https://dl.acm.org/doi/pdf/10.1145/3341694 *)

  let ( <$> ) = F.map
  let ( <*> ) = F.apply
end

module ApplicativeWithPureSeq (F : APPLICATIVE) : sig
  include APPLICATIVE with type 'a t = 'a F.t
  include PURE_SEQ with type 'a t := 'a t
end = struct
  type 'a t = 'a F.t

  let apply = F.apply

  (** PURE_SEQ definitions come from
      {{:https://lean-lang.org/functional_programming_in_lean/Functors___-Applicative-Functors___-and-Monads/The-Complete-Definitions/}Functional
       Programming in Lean} *)

  let pure = F.pure
  let map (type a) (type b) (f : a -> b) (x : a t) = F.apply (pure f) x

  let seq (type a) (type b) (f : (a -> b) t) (x : unit -> a t) : b t =
    F.apply f (x ())

  let seq_left (type a) (type b) (x : a t) (y : unit -> b t) =
    seq (map (fun a _b -> a) x) y

  let seq_right (type a) (type b) (x : a t) (y : unit -> b t) =
    seq (map (fun _a b -> b) x) y
end

(** The [Const] applicative ignores the second type parameter (ex. the value
    type) but accumulates the first type parameter (ex. the key type) with a
    monoid specified as the functor parameter.

    It is described in
    {{:https://hackage.haskell.org/package/base-4.21.0.0/docs/Data-Functor-Const.html}Const
     functor}.

    Use {!const} rather than {!pure} if you need to introduce a value of the
    first type parameter. *)
module ConstApplicativeWithPureSeq (Monoid : sig
  include MONOID

  type const

  val const : const -> t
end) =
struct
  include ApplicativeWithPureSeq (struct
    type 'a t = Monoid.t

    let pure v =
      ignore v;
      Monoid.identity

    let map (type a) (type b) (f : a -> b) (x : a t) =
      ignore f;
      x

    let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
      Monoid.mappend x f
  end)

  type const = Monoid.const

  (** [const k] is the monoid constant [k]. *)
  let const = Monoid.const
end

(** {1 Monads}

    {2 Lifting Monads into Applicatives}

    The order of evaluation is (f state) then (x (f state)) rather than (x
    state) then (f (x state)).

    Why? Haskell has two operators for apply ...

    <*>
    https://hackage.haskell.org/package/base-4.14.0.0/docs/Control-Applicative.html#v:-60--42--62-
    (f state) then (x (f state))

    <**>
    https://hackage.haskell.org/package/base-4.14.0.0/docs/Control-Applicative.html#v:-60--42--42--62-
    (f state) then (x (f state))

    Since [apply] is a synomym for [<*>] we chose (f state) then (x (f state)).

    Confer: https://blog.plover.com/prog/haskell/how-to-ap.html

    Conforming example: https://kndrck.co/posts/peeking_into_state_monads/.

    {2 Definitions} *)

module type MONAD = sig
  include FUNCTOR
  include APPLICATIVE with type 'a t := 'a t

  val return : 'a -> 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
end

module MonadSyntax (F : MONAD) = struct
  let ( <$> ) = F.map
  let ( >>= ) = F.bind
end

module MonadLetSyntax (F : MONAD) = struct
  let ( let* ) = F.bind
end

(** {2 Writer Monads} *)

module type WRITER = sig
  type output
end

module type WRITER_IMPL = sig
  include WRITER

  val empty : output
  val append : output -> output -> output
end

module type MUTABLE_WRITER_ASYNC = sig
  type journal
  type journal_entry_id
  type journal_entry_value
  type 'a promise
end

module type MUTABLE_WRITER_ASYNC_IMPL = sig
  include MUTABLE_WRITER_ASYNC

  val create_empty : unit -> journal

  val new_journal_entry :
    journal_entry_value -> journal_entry_id * journal_entry_value

  val compare_journal_entry_id : journal_entry_id -> journal_entry_id -> int

  val update :
    journal ->
    (journal_entry_id * journal_entry_value) UniqueInsertionList.t ->
    unit
  (** [update journal entries] updates the journal [journal] with the entries
      [entries].

      Each journal entry should have its own {!journal_entry_id} from
      {!new_journal_entry}.

      After the update the journal entries are no longer needed. *)

  val reconcile : dest:journal -> journal -> unit
  (** [reconcile ~dest:journal_dest journal_src] merges and resolves journal
      entry conflicts between journal [journal_dest] and journal [journal_src],
      placing the merged results in [journal_dest]. *)

  val flush : journal -> journal promise
  (** [flush journal] saves any buffer cache of the journal to disk or remote
      storage. *)
end

(** The type of Writer Monads. *)
module type MONAD_WRITER = sig
  include WRITER
  include MONAD with type 'a t = 'a * output

  val tell : output -> unit t
  val run_writer : 'a t -> 'a * output
end

module type MONAD_WRITER_ASYNC = sig
  type journal
  type journal_entry_id
  type journal_entry_value
  type 'a promise

  include
    MONAD
      with type 'a t =
        'a * (journal_entry_id * journal_entry_value) UniqueInsertionList.t

  val post_entry : journal_entry_value -> unit t
end

(** The type of Writer Monads transformers. *)
module type MONAD_WRITER_T = sig
  include WRITER
  module LiftedIntoWriter : MONAD
  include MONAD with type 'a t = ('a * output) LiftedIntoWriter.t

  val tell : output -> unit t
  val run_writer : 'a t -> ('a * output) LiftedIntoWriter.t
  val lift : 'a LiftedIntoWriter.t -> 'a t
end

module type MONAD_WRITER_ASYNC_T = sig
  include MUTABLE_WRITER_ASYNC
  module LiftedIntoWriter : MONAD

  include
    MONAD
      with type 'a t =
        ('a
        * journal
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
        LiftedIntoWriter.t

  val post_entry : journal_entry_value -> unit t
  val sync_writer : 'a t -> 'a t
  val lift : 'a LiftedIntoWriter.t -> 'a t
end

(** Writer Monad transformer. *)
module MonadWriterT (S : sig
  include WRITER_IMPL
  module LiftedIntoWriter : MONAD
end) :
  MONAD_WRITER_T
    with type output = S.output
     and module LiftedIntoWriter = S.LiftedIntoWriter = struct
  type output = S.output

  module LiftedIntoWriter = S.LiftedIntoWriter

  type 'a t = ('a * output) S.LiftedIntoWriter.t

  let pure a = S.LiftedIntoWriter.pure (a, S.empty)
  let return = pure

  let map (type a) (type b) (f : a -> b) (x : a t) : b t =
    let ( let* ) = S.LiftedIntoWriter.bind in
    let* a, output' = x in
    S.LiftedIntoWriter.return (f a, output')

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    (* REMEMBER: Our odoc comments say order of evaluation is (f state) then (x (f state))
         rather than (x state) then (f (x state)). *)
    let ( let* ) = S.LiftedIntoWriter.bind in
    let* f_a_b, f_output = f in
    let* a, a_output = x in
    S.LiftedIntoWriter.return (f_a_b a, S.append f_output a_output)

  let bind (type a) (type b) (m : a t) (f : a -> b t) : b t =
    let ( let* ) = S.LiftedIntoWriter.bind in
    let* a, m_output = m in
    let* b, f_output = f a in
    S.LiftedIntoWriter.return (b, S.append m_output f_output)

  let tell o = S.LiftedIntoWriter.return ((), o)

  let lift m =
    S.LiftedIntoWriter.bind m (fun x -> S.LiftedIntoWriter.return (x, S.empty))

  let run_writer m = m
end

(** Writer Async Monad transformer. *)
module MonadWriterAsyncT (WA : sig
  include MUTABLE_WRITER_ASYNC_IMPL
  module LiftedIntoWriter : MONAD
end) : sig
  include
    MONAD_WRITER_ASYNC_T
      with type journal = WA.journal
       and type journal_entry_id = WA.journal_entry_id
       and type journal_entry_value = WA.journal_entry_value
       and type 'a promise = 'a WA.promise
       and module LiftedIntoWriter = WA.LiftedIntoWriter

  val run_writer_async : 'a t -> ('a * journal) LiftedIntoWriter.t
end = struct
  type journal = WA.journal
  type journal_entry_id = WA.journal_entry_id
  type journal_entry_value = WA.journal_entry_value
  type 'a promise = 'a WA.promise

  module LiftedIntoWriter = WA.LiftedIntoWriter

  module JournalEntryOrd = struct
    type t = journal_entry_id * journal_entry_value

    let compare a b = WA.compare_journal_entry_id (fst a) (fst b)
  end

  let empty_journalentries = UniqueInsertionList.empty (module JournalEntryOrd)

  type 'a t =
    ('a
    * journal
    * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
    WA.LiftedIntoWriter.t

  let pure a =
    WA.LiftedIntoWriter.pure (a, WA.create_empty (), empty_journalentries)

  let return = pure

  let map (type a) (type b) (f : a -> b) (x : a t) : b t =
    let ( let* ) = WA.LiftedIntoWriter.bind in
    let* a, j', je' = x in
    WA.LiftedIntoWriter.return (f a, j', je')

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    (* REMEMBER: Our odoc comments say order of evaluation is (f state) then (x (f state))
         rather than (x state) then (f (x state)). *)
    let ( let* ) = WA.LiftedIntoWriter.bind in
    let* f_a_b, f_j, f_je = f in
    let* a, a_j, a_je = x in
    WA.reconcile ~dest:f_j a_j;
    WA.LiftedIntoWriter.return
      (f_a_b a, f_j, UniqueInsertionList.append f_je a_je)

  let bind (type a) (type b) (m : a t) (f : a -> b t) : b t =
    let ( let* ) = WA.LiftedIntoWriter.bind in
    let* a, m_j, m_je = m in
    let* b, f_j, f_je = f a in
    WA.reconcile ~dest:m_j f_j;
    WA.LiftedIntoWriter.return (b, m_j, UniqueInsertionList.append m_je f_je)

  let post_entry value =
    let id, value = WA.new_journal_entry value in
    let je = UniqueInsertionList.add (id, value) empty_journalentries in
    let journal = WA.create_empty () in
    WA.update journal je;
    WA.LiftedIntoWriter.return ((), journal, empty_journalentries)

  let lift m =
    WA.LiftedIntoWriter.bind m (fun x ->
        WA.LiftedIntoWriter.return (x, WA.create_empty (), empty_journalentries))

  let sync_writer (type a) (m : a t) : a t =
    let ( let* ) = WA.LiftedIntoWriter.bind in
    let* a, j', je' = m in
    WA.update j' je';
    WA.LiftedIntoWriter.return (a, j', empty_journalentries)

  let run_writer_async (type a) (m : a t) : (a * journal) LiftedIntoWriter.t =
    WA.LiftedIntoWriter.map
      (fun (a, j', je') ->
        WA.update j' je';
        (a, j'))
      m
end

(** {2 State Monads} *)

(** Messages to asynchronously update states.

    The [StateMessage] contains an "message object" {!obj} which is a member of
    an extensible type called a "message class" {!cls}. The class is present for
    debugging, especially to find why an state message was not handled.

    The extensibility lets multiple monad implementations, especially monad
    transformations, have a unified way to communicate state updates. In other
    words, the extensibility is the primary way that async state monads compose.
*)
module StateMessage : sig
  type cls = private int
  type obj = ..
  type t = private Value : cls * obj -> t

  val new_class : string -> (cls, string * Printexc.raw_backtrace) result
  (** [new_class name where] makes a new class named [name].

      The [name] must be unique, and should have enough information for a
      developer to know where the class was created. For example, in MlFront use
      the fully qualified module id as part of the name. In conventional OCaml,
      use a combination of the findlib library name and module name.

      An error is returned if the class already exists. The error
      [(message, location)] will contain an error message and the location where
      the original class with the same name was created. *)

  val new_class_exn : string -> cls
  (** [new_class_exn name where] makes a new class named [name], raising an
      {!Invalid_argument} exception if the class has already been created.

      The [name] must be unique, and should have enough information for a
      developer to know where the class was created. For example, in MlFront use
      the fully qualified module id as part of the name. In conventional OCaml,
      use a combination of the findlib library name and module name.

      An {!Invalid_argument} exception is raised if the class already exists.
      The exception [(message, location)] will contain an error message and the
      location where the original class with the same name was created. *)

  val create : cls -> obj -> t
  (** [create cls obj] creates a state message of class [cls] with the object
      [obj]. *)

  val show : t -> string
  (** [show message] shows the name of the class that the state message
      [message] belongs to and the location where the class was created. *)

  val downcast : t -> cls -> obj option
  (** [downcast message cls] returns the object if and only if the message
      [message] belongs to the class [cls]. *)
end = struct
  type cls = int
  type obj = ..
  type t = Value : cls * obj -> t

  module ClassMap = Map.Make (String)
  module InverseClassMap = Map.Make (Int)

  type classinfo = { origin : Printexc.raw_backtrace; class_name : string }

  let classmap : classinfo ClassMap.t ref = ref ClassMap.empty
  let invclassmap : classinfo InverseClassMap.t ref = ref InverseClassMap.empty

  let new_class =
    let next_clazz_id = ref 1 in
    fun class_name ->
      match ClassMap.find_opt class_name !classmap with
      | Some { origin; class_name = _ } ->
          Error
            ( Printf.sprintf "The class `%s` was already created." class_name,
              origin )
      | None ->
          let origin : Printexc.raw_backtrace = Printexc.get_callstack 20 in
          let id = !next_clazz_id in
          next_clazz_id := id + 1;
          let info = { origin; class_name } in
          classmap := ClassMap.add class_name info !classmap;
          invclassmap := InverseClassMap.add id info !invclassmap;
          Ok id

  let new_class_exn class_name =
    match new_class class_name with
    | Ok v -> v
    | Error (message, origin) ->
        raise
          (Invalid_argument
             (Printf.sprintf "%s\nThe original class was created at:\n%s%!"
                message
                (Printexc.raw_backtrace_to_string origin)))

  let create cls obj = Value (cls, obj)

  let show : t -> string = function
    | Value (cls, _) ->
        let { class_name; origin } = InverseClassMap.find cls !invclassmap in
        let origin_string = Printexc.raw_backtrace_to_string origin in
        Printf.sprintf "A message of class `%s` created at:\n%s%!" class_name
          origin_string

  let downcast : t -> cls -> obj option = function
    | Value (cls, obj) -> fun cls' -> if cls = cls' then Some obj else None
end

module type STATE = sig
  type state
end

module type MUTABLE_STATE_ASYNC = sig
  include STATE

  type 'a promise
end

(** The implementation of state in an asynchronous environment.

    The state implementation must have atomic updates. *)
module type MUTABLE_STATE_ASYNC_IMPL = sig
  include MUTABLE_STATE_ASYNC

  val update : state -> StateMessage.t list -> unit
  (** [update state messages] synchronously and atomically updates the state
      [state] with the state messages [messages].

      After the update the messages are no longer needed.

      Only a local, in-memory cache of the state must have synchronous updates.
      If the state is remote, it is expected that the state implementation will
      maintain a local list of messages that have yet to be sent to the remote
      state service. The {!flush} function is provided to move the pending
      messages from the local state to the remote state service. *)

  val flush : state -> unit promise
  (** [flush state] saves any buffer cache of the state to disk or remote
      storage. *)
end

module type MONAD_STATE = sig
  include STATE
  include MONAD with type 'a t = state -> 'a * state

  val get : state t
  val gets : (state -> 'a) -> 'a t
  val put : state -> unit t
  val modify : (state -> state) -> unit t
  val run_state : 'a t -> state -> 'a * state
  val exec_state : 'a t -> state -> state
end

module type MONAD_STATE_ASYNC = sig
  type state
  type 'a promise

  include MONAD with type 'a t = (state -> 'a * StateMessage.t list) promise

  val get : state t
  val gets : (state -> 'a) -> 'a t
  val put : state -> unit t
  val post_msg : StateMessage.t list -> unit t
  val sync_state : 'a t -> 'a t
  val run_state_async : 'a t -> state -> ('a * state) promise
  val exec_state_async : 'a t -> state -> state promise
end

module MonadState (S : STATE) : MONAD_STATE with type state = S.state = struct
  type state = S.state
  type 'a t = state -> 'a * state

  let pure a (state : state) = (a, state)
  let return a (state : state) = (a, state)

  let map (type a) (type b) (f : a -> b) (x : a t) : b t =
   fun state ->
    let a, state' = x state in
    (f a, state')

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
   fun state ->
    (* REMEMBER: Our odoc comments say order of evaluation is (f state) then (x (f state))
         rather than (x state) then (f (x state)). *)
    let f_a_b, state' = f state in
    let a, state'' = x state' in
    (f_a_b a, state'')

  let bind (type a) (type b) (t : a t) (f : a -> b t) : b t =
   fun state ->
    let a, state' = t state in
    let b, state'' = f a state' in
    (b, state'')

  let get = fun state -> (state, state)
  let gets = fun read_state -> fun state -> (read_state state, state)
  let put s = fun (_ : state) -> ((), s)
  let modify = fun map_state -> fun state -> ((), map_state state)
  let run_state = fun (t : 'a t) -> fun (s : state) -> t s
  let exec_state = fun (t : 'a t) -> fun (s : state) -> snd (t s)
end

open struct
  (** [compose f g x] is [f (g x)] and is available in OCaml 5 as
      {!Fun.compose}. *)
  let compose f g x = f (g x)

  let fmap ~pure ~bind f xs =
    let ( >>= ) = bind in
    xs >>= fun x -> pure (f x)
end

module MonadStateWithPureSeq (S : STATE) : sig
  include
    MONAD_STATE
      with type state = S.state
       and type 'a t = S.state -> 'a * S.state

  include PURE_SEQ with type 'a t := S.state -> 'a * S.state

  val get : S.state t
  val gets : (S.state -> 'a) -> 'a t
  val put : S.state -> unit t
  val modify : (S.state -> S.state) -> unit t
  val run_state : 'a t -> S.state -> 'a * S.state
  val exec_state : 'a t -> S.state -> S.state
end = struct
  module M1 = MonadState (S)

  type state = S.state
  type 'a t = S.state -> 'a * S.state

  let return = M1.return
  let bind = M1.bind

  (** PURE_SEQ definitions come from
      {{:https://lean-lang.org/functional_programming_in_lean/Functors___-Applicative-Functors___-and-Monads/The-Complete-Definitions/}Functional
       Programming in Lean} *)

  let pure = M1.return
  let map (type a) (type b) (f : a -> b) (x : a t) = bind x (compose pure f)

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    bind f (fun y -> map y x)

  let seq f x = bind f (fun y -> map y (x ()))

  let seq_left (type a) (type b) (x : a t) (y : unit -> b t) : a t =
    bind x (fun a -> bind (y ()) (fun _b -> pure a))

  let seq_right (type a) (type b) (x : a t) (y : unit -> b t) : b t =
    bind x (fun _a -> y ())

  let get = M1.get
  let gets = M1.gets
  let put = M1.put
  let modify = M1.modify
  let run_state = M1.run_state
  let exec_state = M1.exec_state
end

(** {2 Promise Monads} *)

module type PROMISE = sig
  type 'a promise
end

module type PROMISE_IMPL = sig
  include PROMISE

  val return_promise : 'a -> 'a promise
  val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise
end

type 'resolved_promise_state universal_promise_state =
  | Pending
  | Resolved of 'resolved_promise_state
  | Rejected of exn
      (** The type ['resolved_promise_state universal_promise_state] is the set
          of states a promise can be in. *)

(** The type of promise monad.

    The promise monad is described in
    {{:https://courses.cs.cornell.edu/cs3110/2021sp/textbook/adv/promises.html}CS
     3110 - Functional Programming in OCaml}.

    Unlike other monads, there is no:

    {[
      val run_promise : unit t -> unit
      (** [run_promise promise] runs the promise [promise]. *)
    ]}

    That is because some promise implementations are control of the entire
    runtime or are part of the language (ex. effects in OCaml 5, await in JS,
    etc.). It is the users' responsibility to unpack the promise that works in
    whatever environment the program is running. *)
module type MONAD_PROMISE = sig
  type 'a t
  (** The type ['a t] is the set of (future) promises for values of type ['a].
  *)

  type 'a resolver
  (** The type ['a t] is the type of resolvers for pending promises of a value
      of type ['a]. *)

  type resolved_promise_state
  (** The type [resolved_promise_state] is the set of states a [Resolved]
      promise can be in. The set will be either type ['a] in {!t} or a reversed
      monadic transformation of type ['a] which you need to unwrap. In other
      words, the resolution has no knowledge of the transformations of the monad
      (nor should it!). *)

  include MONAD with type 'a t := 'a t

  val make_promise : unit -> 'a t * 'a resolver
  (** [make_promise ()] is a new promise and resolver. The promise is pending.
  *)

  val return : 'a -> 'a t
  (** [return x] is a new promise that is already resolved with value [x]. *)

  val promise_state : 'a t -> resolved_promise_state universal_promise_state
  (** [promise_state p] is the state of the promise *)

  val resolve : 'a resolver -> 'a -> unit
  (** [resolve r x] resolves the promise [p] associated with [r] with value [x],
      meaning that [state p] will become [Resolved x]. Requires: [p] is pending.
  *)

  val reject : 'a resolver -> exn -> unit
  (** [reject r x] rejects the promise [p] associated with [r] with exception
      [x], meaning that [state p] will become [Rejected x]. Requires: [p] is
      pending. *)

  val parallel : 'a t list -> 'a list t
  (** [parallel ps] is a promise that resolves when all the promises in [ps]
      resolve, or rejects when any promise in [ps] rejects. The order of the
      resolved values is the same as the order of the promises in [ps]. *)
end

(** The type of Promise Monads transformers. *)
module type MONAD_PROMISE_T = sig
  type 'a promise
  type 'a resolver
  type resolved_promise_state

  module LiftedIntoPromise : MONAD
  include MONAD with type 'a t = 'a LiftedIntoPromise.t promise

  val make_promise : unit -> 'a t * 'a resolver
  val return : 'a -> 'a t
  val promise_state : 'a t -> resolved_promise_state universal_promise_state
  val resolve : 'a resolver -> 'a -> unit
  val reject : 'a resolver -> exn -> unit
  val lift : 'a LiftedIntoPromise.t -> 'a t
  (* val run_promise : 'a t -> 'a LiftedIntoPromise.t promise *)
end

(** Promise Monad transformer. *)
module MonadPromiseT (S : sig
  include MONAD_PROMISE
  module LiftedIntoPromise : MONAD
end) :
  MONAD_PROMISE_T
    with type 'a promise = 'a S.t
     and type 'a resolver = ('a -> unit) * (exn -> unit)
     and type resolved_promise_state = S.resolved_promise_state
     and module LiftedIntoPromise = S.LiftedIntoPromise = struct
  type 'a promise = 'a S.t

  type 'a resolver = ('a -> unit) * (exn -> unit)
  (** Since we need to map the ['a resolver], and Lwt and maybe others do not
      offer the [map], we split up the resolver into a pair of [resolve] and
      [reject] functions. *)

  type resolved_promise_state = S.resolved_promise_state

  module LiftedIntoPromise = S.LiftedIntoPromise

  type 'a t = 'a S.LiftedIntoPromise.t promise

  let pure a = S.return @@ S.LiftedIntoPromise.pure a
  let return = pure

  let lifted_map (type a) (type b) (f : a -> b) (x : a LiftedIntoPromise.t) :
      b LiftedIntoPromise.t =
    fmap ~pure:LiftedIntoPromise.pure ~bind:LiftedIntoPromise.bind f x

  let promise_map (type a) (type b) (f : a -> b) (x : a S.t) : b S.t =
    fmap ~pure:S.return ~bind:S.bind f x

  let lifted_apply mf mx =
    let ( >>= ) = LiftedIntoPromise.bind in
    mf >>= fun f ->
    mx >>= fun x -> LiftedIntoPromise.return (f x)

  let map (type a) (type b) (f : a -> b) (x : a t) : b t =
    promise_map
      (fun (l_x : a LiftedIntoPromise.t) -> lifted_map (fun (a : a) -> f a) l_x)
      x

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    (* REMEMBER: Our odoc comments say order of evaluation is (f state) then (x (f state))
       rather than (x state) then (f (x state)). *)
    let ( >>=- ) = S.bind in
    x >>=- fun (l_a : a LiftedIntoPromise.t) ->
    f >>=- fun (l_f : (a -> b) LiftedIntoPromise.t) ->
    let (l_b : b LiftedIntoPromise.t) = lifted_apply l_f l_a in
    S.return l_b

  let bind (type a) (type b) (m : a t) (f : a -> b t) : b t =
    let ( >>=- ) = S.bind in
    let ( >>=| ) = S.LiftedIntoPromise.bind in
    let (promise : b LiftedIntoPromise.t promise), resolver =
      S.make_promise ()
    in
    let (_ : unit LiftedIntoPromise.t promise) =
      m >>=- fun (l_a : a LiftedIntoPromise.t) ->
      let (l_b : _ LiftedIntoPromise.t) =
        l_a >>=| fun (a : a) ->
        let (b : b t) = f a in
        let (l_b : b LiftedIntoPromise.t promise) =
          b >>=- fun (l_b : b LiftedIntoPromise.t) ->
          S.resolve resolver l_b;
          S.return l_b
        in
        (* We must ignore the promise because we can't use it now!
           We are very very unlikely to have a resolved promise at this point,
           since the LiftedIntoPromise monad may have a delayed callback
           to the above [fun (l_b : b LiftedIntoPromise.t)]. *)
        ignore l_b;
        LiftedIntoPromise.pure ()
      in
      S.return l_b
    in
    promise

  let lift m = S.return m

  let make_promise () =
    let promise, resolver = S.make_promise () in
    let resolve a = S.resolve resolver (LiftedIntoPromise.return a) in
    (promise, (resolve, S.reject resolver))

  let promise_state (type a) (m : a t) :
      resolved_promise_state universal_promise_state =
    S.promise_state m

  let resolve (resolve', _reject') = resolve'
  let reject (_resolve', reject') = reject'
  (* let run_promise m = m *)
end

(** {2 Monad Combinations} *)

(** The type of monads that are both State and Writer monads. *)
module type MONAD_STATE_WRITER = sig
  type state
  type output

  include MONAD with type 'a t = state -> 'a * state * output

  (** {1 State Monad} *)

  val get : state t
  val gets : (state -> 'a) -> 'a t
  val put : state -> unit t
  val modify : (state -> state) -> unit t
  val run_state : 'a t -> state -> 'a * state
  val exec_state : 'a t -> state -> state

  (** {1 Writer Monad} *)

  val tell : output -> unit t
  val run_writer : 'a t -> ('a * output) t
end

module type MONAD_STATE_WRITER_ASYNC = sig
  type state
  type 'a promise
  type journal
  type journal_entry_id
  type journal_entry_value

  include
    MONAD
      with type 'a t =
        (state * journal ->
        ('a
        * StateMessage.t list
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
        promise)
        promise

  (** {1 Promise Monad} *)

  val lift_promise : 'a promise -> 'a t

  (** {1 State Monad} *)

  val get : state t
  val gets : (state -> 'a) -> 'a t
  val post_msg : StateMessage.t list -> unit t
  val sync_state : 'a t -> 'a t
  val run_state_async : 'a t -> state -> ('a * state) promise
  val exec_state_async : 'a t -> state -> state promise

  (** {1 Writer Monad} *)

  val post_entry : journal_entry_value -> unit t
end

(** The type of monads that are async State and Writer monads and also Promise
    monads. *)
module type MONAD_STATE_WRITER_ASYNC_PROMISE = sig
  type state
  type journal
  type journal_entry_id
  type journal_entry_value
  type 'a promise
  type 'a resolver
  type resolved_promise_state

  include
    MONAD
      with type 'a t =
        (state * journal ->
        ('a
        * StateMessage.t list
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
        promise)
        promise

  (** {1 Promise Monad} *)

  val make_promise : unit -> 'a t * 'a resolver
  val promise_state : 'a t -> resolved_promise_state universal_promise_state
  val resolve : 'a resolver -> 'a -> unit
  val reject : 'a resolver -> exn -> unit
  val lift_promise : 'a promise -> 'a t
  val parallel : 'a t list -> 'a list t
  val bind_promise : 'a promise -> ('a -> 'b promise) -> 'b promise
  val return_promise : 'a -> 'a promise

  (** {1 State Monad} *)

  val get : state t
  val gets : (state -> 'a) -> 'a t
  val post_msg : StateMessage.t list -> unit t
  val run_state_async : 'a t -> state -> ('a * state) promise
  val exec_state_async : 'a t -> state -> state promise

  (** {1 Writer Monad} *)

  val post_entry : journal_entry_value -> unit t

  (* NOT PRESENT: val run_writer_async : 'a t -> ('a * journal) promise
     We need the [state] to get the writer, but the API for run_writer_async does not supply it.
     This is a consequence of the design decision to give the writer monad the lowest priority
     among the monads combined in this module. *)

  (** {1 Combined Monad} *)

  val run_state_writer_async : 'a t -> state -> ('a * state * journal) promise
end

(** A builder of a monad that is a state monad and a writer monad. *)
module MonadStateWriterWithPureSeq (S : STATE) (W : WRITER_IMPL) : sig
  include
    MONAD_STATE_WRITER
      with type state = S.state
       and type output = W.output
       and type 'a t = S.state -> 'a * S.state * W.output

  include PURE_SEQ with type 'a t := S.state -> 'a * S.state * W.output
end = struct
  type state = S.state
  type output = W.output
  type 'a t = S.state -> 'a * S.state * W.output

  module M1 = MonadState (S)

  module M2 = MonadWriterT (struct
    type output = W.output

    let empty = W.empty
    let append = W.append

    module LiftedIntoWriter = M1
  end)

  let return v = fun state -> (v, state, W.empty)
  let pure = return

  let bind (type a) (type b) (m : a t) (f : a -> b t) : b t =
   fun state ->
    let a', state', output' = m state in
    let b'', state'', output'' = f a' state' in
    (b'', state'', W.append output' output'')

  let map (type a) (type b) (f : a -> b) (x : a t) : b t =
    bind x (compose pure f)

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    bind f (fun y -> map y x)

  let seq f x = bind f (fun y -> map y (x ()))

  let seq_left (type a) (type b) (x : a t) (y : unit -> b t) : a t =
    bind x (fun a -> bind (y ()) (fun _b -> pure a))

  let seq_right (type a) (type b) (x : a t) (y : unit -> b t) : b t =
    bind x (fun _a -> y ())

  let get : S.state t = fun state -> (state, state, W.empty)
  let gets = fun read_state -> fun state -> (read_state state, state, W.empty)

  let put state =
   fun state' ->
    ignore state';
    ((), state, W.empty)

  let modify trans_state =
   fun state' ->
    let state'' = trans_state state' in
    ((), state'', W.empty)

  let run_state =
   fun (t : 'a t) ->
    fun (s : state) ->
     let a', state', _ = t s in
     (a', state')

  let exec_state =
   fun (t : 'a t) ->
    fun (s : state) ->
     let _, state', _ = t s in
     state'

  let tell o =
   fun state ->
    let m2 = M2.tell o in
    let ((), o'), state' = m2 state in
    ((), state', o')

  let run_writer =
   fun (t : 'a t) ->
    fun (state : state) ->
     let a', state', writer' = t state in
     ((a', writer'), state', writer')
end

(** A builder of a monad that is a combination of a state monad, a writer monad,
    and a promise monad.

    The built monad is not thread safe if it is shared across system threads or
    OCaml 5 domains.

    There were tradeoffs made to combine multiple monads into one, and those
    tradeoffs are informed by the relative priority each monad has to each
    other:

    - The promise monad is the highest priority monad. That means the built
      combo monad {b is} a promise monad, without any loss of fidelity.
    - The state monad is the medium priority monad. You can't access the state
      without waiting for a promise. Furthermore, the (async) state monad's
      update and flusing requires the promise monad.
    - The writer monad is the lowest priority monad, You can't access the
      journal without waiting for a promise {b and} supplying an initial or
      existing state. Furthermore the (async) writer monad's posting requires
      the promise monad.

    {1 State amongst cooperative promise threads}

    Unlike the traditional state monad, the monad that
    [MonadStateWriterPromiseWithPureSeq] builds will only carry a
    {b state identifier} along the sequential series of [bind] calls
    (conventionally using the [let*] or [>>=] operators). The state itself is
    maintained in a map of state identifiers to states that is stored in the
    monad module.

    Precisely, the [MonadStateWriterPromiseWithPureSeq] ... after the functor
    parameters are applied ... maintains a map of state identifiers to states. A
    different state map is maintained if you apply functor parameters again
    (even the same parameters) to [MonadStateWriterPromiseWithPureSeq].

    {b Caution}: The allocated memory for the state value is never reclaimed.

    If you follow the
    {b best practice recommendation to only apply the functor parameters once}
    to build the monad [MonadStateWriterPromiseWithPureSeq], then will only be
    one authorative owner who maintains the states and their storage.

    {1 Writer output amongst cooperative promise threads}

    Unlike the traditional writer monad, the monad that
    [MonadStateWriterPromiseWithPureSeq] builds will only carry the latest
    output (called "journal entries") that has yet to be written to the output
    (called the "journal"). However, the journal itself is stored within the
    monad module's map of state identifiers to states. Periodically the journal
    entries are moved into the journal; you can explicitly do this with
    {!sync_writer}.

    A good analogy is having thread-local buffered log messages (the journal
    entries), which are periodically synced into global log messages (the
    journal).

    The monad's module state identifier map is the authoritative owner of the
    journal.

    You are required to {!flush} the journal as well. *)
module MonadStateWriterPromiseWithPureSeq
    (P : MONAD_PROMISE)
    (SA : sig
      include MUTABLE_STATE_ASYNC_IMPL with type 'a promise = 'a P.t
    end)
    (WA : sig
      include MUTABLE_WRITER_ASYNC_IMPL with type 'a promise = 'a P.t
    end) : sig
  include
    MONAD_STATE_WRITER_ASYNC_PROMISE
      with type state = SA.state
       and type journal = WA.journal
       and type journal_entry_id = WA.journal_entry_id
       and type journal_entry_value = WA.journal_entry_value
       and type 'a promise = 'a P.t
       and type 'a resolver = ('a -> unit) * (exn -> unit)
       and type resolved_promise_state = P.resolved_promise_state
       and type 'a t =
        (SA.state * WA.journal ->
        ('a
        * StateMessage.t list
        * (WA.journal_entry_id * WA.journal_entry_value) UniqueInsertionList.t)
        P.t)
        P.t

  include
    PURE_SEQ
      with type 'a t :=
        (SA.state * WA.journal ->
        ('a
        * StateMessage.t list
        * (WA.journal_entry_id * WA.journal_entry_value) UniqueInsertionList.t)
        P.t)
        P.t

  val sync_writer : 'a t -> 'a t
  val sync_state : 'a t -> 'a t
end = struct
  type state = SA.state
  type journal = WA.journal
  type journal_entry_id = WA.journal_entry_id
  type journal_entry_value = WA.journal_entry_value
  type 'a promise = 'a P.t

  type 'a resolver = ('a -> unit) * (exn -> unit)
  (** Since we need to map the ['a resolver], and Lwt and maybe others do not
      offer the [map], we split up the resolver into a pair of [resolve] and
      [reject] functions. *)

  type resolved_promise_state = P.resolved_promise_state

  type 'a t =
    (state * journal ->
    ('a
    * StateMessage.t list
    * (WA.journal_entry_id * WA.journal_entry_value) UniqueInsertionList.t)
    P.t)
    P.t

  let ( let* ) = P.bind
  let bind_promise = P.bind
  let return_promise = P.return

  module JournalEntryOrd = struct
    type t = WA.journal_entry_id * WA.journal_entry_value

    let compare a b = WA.compare_journal_entry_id (fst a) (fst b)
  end

  let empty_journalentries = UniqueInsertionList.empty (module JournalEntryOrd)

  let lift_promise (type a) (p : a promise) : a t =
    P.pure @@ fun (_state, _journal) ->
    let lifted :
        (a
        * StateMessage.t list
        * (WA.journal_entry_id * WA.journal_entry_value) UniqueInsertionList.t)
        P.t =
      P.map (fun (a : a) -> (a, [], empty_journalentries)) p
    in
    lifted

  module M1 = MonadState (SA)

  module M2 = MonadWriterAsyncT (struct
    type journal = WA.journal
    type journal_entry_id = WA.journal_entry_id
    type journal_entry_value = WA.journal_entry_value
    type 'a promise = 'a WA.promise

    let new_journal_entry = WA.new_journal_entry
    let compare_journal_entry_id = WA.compare_journal_entry_id
    let create_empty = WA.create_empty
    let update = WA.update
    let reconcile = WA.reconcile
    let flush = WA.flush

    module LiftedIntoWriter = M1
  end)

  let return v =
    P.pure @@ fun (state, journal) ->
    ignore state;
    ignore journal;
    P.pure (v, [], empty_journalentries)

  let pure = return

  let mutate_records (state, journal) msgs journalentries =
    SA.update state msgs;
    WA.update journal journalentries

  let bind (type a) (type b) (m : a t) (f : a -> b t) : b t =
    let* a_t = m in
    P.pure @@ fun (state, journal) ->
    let* a, msgs, journalentries = a_t (state, journal) in
    mutate_records (state, journal) msgs journalentries;
    let* b_t = f a in
    let* b, msgs, journalentries = b_t (state, journal) in
    mutate_records (state, journal) msgs journalentries;
    ignore journal;
    P.pure (b, [], empty_journalentries)

  let map (type a) (type b) (f : a -> b) (x : a t) : b t =
    bind x (compose pure f)

  let apply (type a) (type b) (f : (a -> b) t) (x : a t) : b t =
    bind f (fun y -> map y x)

  let seq f x = bind f (fun y -> map y (x ()))

  let seq_left (type a) (type b) (x : a t) (y : unit -> b t) : a t =
    bind x (fun a -> bind (y ()) (fun _b -> pure a))

  let seq_right (type a) (type b) (x : a t) (y : unit -> b t) : b t =
    bind x (fun _a -> y ())

  let get : SA.state t =
    P.pure @@ fun (state, journal) ->
    ignore journal;
    P.pure @@ (state, [], empty_journalentries)

  let gets =
   fun read_state ->
    P.pure @@ fun (state, journal) ->
    ignore journal;
    P.pure @@ (read_state state, [], empty_journalentries)

  let post_msg msgs =
    P.pure @@ fun (state, journal) ->
    mutate_records (state, journal) msgs empty_journalentries;
    ignore journal;
    P.pure ((), [], empty_journalentries)

  let flush_all (state, journal) =
    let* journal = WA.flush journal in
    let* () = SA.flush state in
    P.pure (state, journal)

  let sync_state (type a) (t : a t) : a t =
    P.pure @@ fun (state, journal) ->
    let* a_t = t in
    let* a, msgs, journalentries = a_t (state, journal) in
    mutate_records (state, journal) msgs journalentries;
    let* state = flush_all (state, journal) in
    ignore state;
    P.pure (a, [], empty_journalentries)

  let run_state_async (t : 'a t) (state : state) =
    let* a_t = t in
    let journal = WA.create_empty () in
    let* a, msgs, journalentries = a_t (state, journal) in
    mutate_records (state, journal) msgs journalentries;
    let* state, journal = flush_all (state, journal) in
    ignore journal;
    P.pure (a, state)

  let exec_state_async (t : 'a t) (state : state) =
    let* a_t = t in
    let journal = WA.create_empty () in
    let* a, msgs, journalentries = a_t (state, journal) in
    ignore a;
    mutate_records (state, journal) msgs journalentries;
    let* state, journal = flush_all (state, journal) in
    ignore journal;
    P.pure state

  let post_entry value =
    P.pure @@ fun (state, journal) ->
    let id, value = WA.new_journal_entry value in
    (* Using WA.update now will execute the entry now. *)
    let journalentries =
      UniqueInsertionList.add (id, value) empty_journalentries
    in
    mutate_records (state, journal) [] journalentries;
    ignore journal;
    P.pure ((), [], empty_journalentries)

  let sync_writer (type a) (t : a t) : a t =
    P.pure @@ fun (state, journal) ->
    let* a_t = t in
    let* a, msgs, journalentries = a_t (state, journal) in
    let* journal = WA.flush journal in
    mutate_records (state, journal) msgs journalentries;
    ignore journal;
    P.pure (a, [], empty_journalentries)

  let make_promise () =
    let promise, resolver = P.make_promise () in
    let resolve a =
      P.resolve resolver (fun (state, journal) ->
          (* no update to [state] needed *)
          ignore state;
          ignore journal;
          P.pure (a, [], empty_journalentries))
    in
    let t = promise in
    (t, (resolve, P.reject resolver))

  let promise_state (type a) (m : a t) :
      resolved_promise_state universal_promise_state =
    P.promise_state m

  let resolve (resolve', _reject') = resolve'
  let reject (_resolve', reject') = reject'

  let parallel (type a) (ps : a t list) : a list t =
    P.pure @@ fun (state, journal) ->
    let list_of_child_promises :
        (a
        * StateMessage.t list
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
        promise
        list =
      List.map
        (fun p ->
          let* p' = p in
          p' (state, journal))
        ps
    in
    let promise_of_child_list :
        (a
        * StateMessage.t list
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
        list
        promise =
      P.parallel list_of_child_promises
    in
    let* child_list :
        (a
        * StateMessage.t list
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t)
        list =
      promise_of_child_list
    in
    let (a_list, msgs, journalentries) :
        a list
        * StateMessage.t list list
        * (journal_entry_id * journal_entry_value) UniqueInsertionList.t =
      List.fold_right
        (fun (a, b, c) (acc_a, acc_b, acc_c) ->
          (a :: acc_a, b :: acc_b, UniqueInsertionList.append acc_c c))
        child_list
        ([], [], empty_journalentries)
    in
    P.pure (a_list, List.flatten msgs, journalentries)

  let run_state_writer_async (t : 'a t) (state : state) =
    let* a_t = t in
    let journal = WA.create_empty () in
    let* a, msgs, journalentries = a_t (state, journal) in
    let* state, journal = flush_all (state, journal) in
    mutate_records (state, journal) msgs journalentries;
    P.pure (a, state, journal)
end

module type SELECTIVE = sig
  type 'a t

  val return : 'a -> 'a t
  val map : ('a -> 'b) -> 'a t -> 'b t

  val select : ('a, 'b) Either.t t -> ('a -> 'b) t -> 'b t
  (** The [select] method which gives meaning to the composition of two
      effectful computations where the second computation depends on the first
      one.

      Described in
      {{:https://dl.acm.org/doi/pdf/10.1145/3341694}Selective Applicative
       Functors} *)
end

module SelectiveSyntax (F : SELECTIVE) = struct
  (* Symbols from https://dl.acm.org/doi/pdf/10.1145/3341694 *)

  let ( <$> ) = F.map
  let ( <*? ) = F.select
end

(** An intermediate constraint between an applicative and a monad. It behaves as
    if it were a monad unless the build script uses {!S.seq_left}, where the
    Selective constraint can choose to short-circuit with the right-side of the
    selection.

    Described in
    {{:https://dl.acm.org/doi/pdf/10.1145/3341694}Selective Applicative
     Functors}. *)
module SelectiveWithPureSeq (F : SELECTIVE) : sig
  include SELECTIVE with type 'a t = 'a F.t
  include PURE_SEQ with type 'a t := 'a t
end = struct
  type 'a t = 'a F.t

  let return = F.return
  let select = F.select
  let pure = F.return
  let map = F.map

  let seq (type a) (type b) (f : (a -> b) t) (x : unit -> a t) : b t =
    F.select
      (F.map (fun a -> Either.left a) (x ()) : (a, b) Either.t t)
      (f : (a -> b) t)

  let seq_left (type a) (type b) (x : a t) (y : unit -> b t) : a t =
    F.select
      (F.map (fun a -> Either.right a) x : (a, a) Either.t t)
      (F.map (fun _b -> fun a -> a) (y ()) : (a -> a) t)

  let seq_right (type a) (type b) (x : a t) (y : unit -> b t) : b t =
    F.select
      (F.map (fun a -> Either.left a) x : (a, b) Either.t t)
      (F.map (fun b -> fun _a -> b) (y ()) : (a -> b) t)
end