core.cljc

;; Copyright (c) 2015-2019 Andrey Antukh <niwi@niwi.nz>
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;;
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(ns promesa.core
  (:refer-clojure :exclude [delay spread promise
                            await map mapcat run!
                            future let loop recur
                            -> ->> as-> with-redefs do])
  (:require
   [promesa.protocols :as pt]
   [clojure.core :as c]
   [promesa.exec :as exec]
   [promesa.impl :as impl])
  #?(:cljs (:require-macros [promesa.core]))
  #?(:clj
     (:import
      java.util.concurrent.CompletableFuture
      java.util.concurrent.CompletionStage
      java.util.concurrent.TimeoutException)))

;; --- Promise

(defn resolved
  "Return a resolved promise with provided value."
  [v]
  (impl/resolved v))

(defn rejected
  "Return a rejected promise with provided reason."
  [v]
  (impl/rejected v))

(defn deferred
  "Creates an empty promise instance."
  []
  (impl/deferred))

(defn promise
  "The coerce based promise constructor. Creates a appropriate promise
  instance depending on the provided value.

  If an executor is provided, it will be used to resolve this
  promise."
  ([v]
   (pt/-promise v))
  ([v executor]
   (pt/-map (pt/-promise v) identity executor)))

(defn wrap
  "A convenience alias for `promise` coercion function that only accepts
  a single argument."
  [v]
  (pt/-promise v))

(defn create
  "Create a promise instance from a factory function. If an executor is
  provided, the factory will be executed in the provided executor.

  A factory function looks like `(fn [resolve reject] (resolve 1))`."
  ([f]
   (c/let [d (impl/deferred)]
     (try
       (f #(pt/-resolve! d %)
          #(pt/-reject! d %))
       (catch #?(:clj Exception :cljs :default) e
         (pt/-reject! d e)))
     d))
  ([f executor]
   (c/let [d (impl/deferred)]
     (exec/run! executor (fn []
                           (try
                             (f #(pt/-resolve! d %)
                                #(pt/-reject! d %))
                             (catch #?(:clj Exception :cljs :default) e
                               (pt/-reject! d e)))))
     d)))

(defn promise?
  "Return true if `v` is a promise instance."
  [v]
  (satisfies? pt/IPromise v))

  ;; #?(:clj (instance? CompletionStage v)
  ;;    :cljs (instance? impl/*default-promise* v)))

(defn deferred?
  "Return true if `v` is a promise instance (alias to `promise?`)."
  [v]
  #?(:clj (instance? CompletionStage v)
     :cljs (instance? impl/*default-promise* v)))

#?(:cljs
   (defn thenable?
     "Returns true if `v` is a promise like object."
     [v]
     (and (object? v) (fn? (unchecked-get v "then")))))

;; Predicates

(defn resolved?
  "Returns true if promise `p` is already fulfilled."
  [p]
  (pt/-resolved? p))

(defn rejected?
  "Returns true if promise `p` is already rejected."
  [p]
  (pt/-rejected? p))

(defn pending?
  "Returns true if promise `p` is stil pending."
  [p]
  (pt/-pending? p))

(defn extract
  "Returns the current promise value."
  [p]
  (pt/-extract p))

(def done?
  "Returns true if promise `p` is already done."
  (complement pending?))

;; Chaining

(defn then
  "Chains a computation `f` (function) to be executed when the promise
  `p` is successfully resolved.

  The computation will be executed in the calling thread by default;
  you also can provide a custom executor.

  If the function `f` returns a promise instance, it will be
  automatically unwrapped."
  ([p f]
   (pt/-then (pt/-promise p) f))
  ([p f executor]
   (pt/-then (pt/-promise p) f executor)))

(defn bind
  ([p f]
   (pt/-bind (pt/-promise p) f))
  ([p f executor]
   (pt/-bind (pt/-promise p) f executor)))

(defn then'
  "Chains a computation `f` (function) to be executed when the promise
  `p` is successfully resolved.

  The computation will be executed in the calling thread by default;
  you also can provide a custom executor.

  Don't perform flatten on the result."
  ([p f]
   (pt/-map (pt/-promise p) f))
  ([p f executor]
   (pt/-map (pt/-promise p) f executor)))

(defn map
  "Chains a computation `f` (function) to be executed when the promise
  `p` is successfully resolved.

  Unlike `then` this does not performs automatic promise flattening.
  This is designed to be used with `->>`."
  ([f p]
   (pt/-map (pt/-promise p) f))
  ([executor f p]
   (pt/-map (pt/-promise p) f executor)))

(defn mapcat
  "Chains a computation `f` (function) to be executed when the promise
  `p` is successfully resolved. always expecting that `f` returns a
  promise that will be automatically unwrapped.

  This is just a stricter version of `then` with reversed arguments in
  the same way as `map`.

  This is designed to be used with `->>`."
  ([f p]
   (pt/-bind (pt/-promise p) f))
  ([executor f p]
   (pt/-bind (pt/-promise p) f executor)))

(defn chain
  "Chain variable number of computations to be executed
  serially. Analogous to `then` that accepts variable number of
  functions."
  ([p f] (then p f))
  ([p f & fs] (reduce #(then %1 %2) p (cons f fs))))

(defn chain'
  "Chain variable number of computations to be executed serially. Unlike
  `chain` does not flattens the return value of each step (probably
  this is more performant than `chain`)."
  ([p f] (then' p f))
  ([p f & fs] (reduce pt/-map (pt/-promise p) (cons f fs))))

(defn handle
  "Executes `f` when the promise `p` is resolved or is rejected. Returns
  a promise resolved with the return value of `f` function."
  ([p f]
   (pt/-handle (pt/-promise p) f))
  ([p f executor]
   (pt/-handle (pt/-promise p) f executor)))

(defn finally
  "Attach a potentially side-effectful handler to promise that will be
  executed independently if promise is resolved or rejected.

  Returns the original promise and the return value of `f` function is
  ignored."
  ([p f]
   (pt/-finally (pt/-promise p) f))
  ([p f executor]
   (pt/-finally (pt/-promise p) f executor)))

(defn catch
  "Executes `f` when the promise `p` is rejected. Returns a promise
  resolved with the return value of `f` function handler."
  ([p f]
   (pt/-thenErr (pt/-promise p) f))
  ([p pred-or-type f]
   (c/let [accept? (if (ifn? pred-or-type)
                     pred-or-type
                     #(instance? pred-or-type %))]
     (pt/-thenErr
      (pt/-promise p)
      (fn [e]
        (if (accept? e)
          (f e)
          (impl/rejected e)))))))

(defn catch'
  "Executes `f` when the promise `p` is rejected. Returns a promise
  resolved with the return value of `f` function handler."
  ([p f]
   (pt/-mapErr (pt/-promise p) f))
  ([p pred-or-type f]
   (c/let [accept? (if (ifn? pred-or-type)
                     pred-or-type
                     #(instance? pred-or-type %))]
     (pt/-mapErr
      (pt/-promise p)
      (fn [e]
        (if (accept? e)
          (f e)
          (impl/rejected e)))))))

(defn error
  "Same as `catch` but with parameters inverted."
  ([f p] (catch p f))
  ([f type p] (catch p type f)))

(def err
  "A short alias for `error` function."
  error)

(defn all
  "Given an array of promises, return a promise
  that is fulfilled  when all the items in the
  array are fulfilled.

  Example:

  (-> (all [(promise :first-promise)
            (promise :second-promise)]
      (then (fn [[first-result second-result]]))
       (println (str first-result \", \" second-result)

  Will print out
  :first-promise, :second-promise.

  If at least one of the promises is rejected, the resulting promise will be
  rejected."
  [promises]
  #?(:cljs (c/-> (.all impl/*default-promise* (into-array promises))
                 (then' vec))
     :clj (c/let [promises (clojure.core/map pt/-promise promises)]
            (then' (c/->> (into-array CompletableFuture promises)
                          (CompletableFuture/allOf))
                   (fn [_]
                     (mapv pt/-extract promises))))))

(defn race
  [promises]
  #?(:cljs (.race impl/*default-promise* (into-array (cljs.core/map pt/-promise promises)))
     :clj (CompletableFuture/anyOf (c/->> (clojure.core/map pt/-promise promises)
                                          (into-array CompletableFuture)))))

(defn any
  "Given an array of promises, return a promise that is fulfilled when
  first one item in the array is fulfilled."
  ([promises]
   (any promises ::default))
  ([promises default]
   (c/let [state (atom {:resolved false
                        :counter (count promises)
                        :rejections []})]
     (create
      (fn [resolve reject]
        (doseq [p promises]
          (c/-> (pt/-promise p)
                (then (fn [v]
                        (when-not (:resolved @state)
                          (swap! state (fn [state]
                                         (c/-> state
                                               (assoc :resolved true)
                                               (update :counter dec))))
                          (resolve v))))
                (catch (fn [e]
                         (swap! state (fn [state]
                                        (c/-> state
                                              (update  :counter dec)
                                              (update :rejections conj e))))
                         (c/let [{:keys [resolved counter rejections]} @state]
                           (when (and (not resolved) (= counter 0))
                             (if (= default ::default)
                               (reject (ex-info "No promises resolved"
                                                {:rejections rejections}))
                               (resolve default)))))))))))))

(defn run!
  "A promise aware run! function."
  ([f coll] (run! f coll exec/current-thread-executor))
  ([f coll executor] (reduce #(then %1 (fn [_] (f %2))) (promise nil executor) coll)))

;; Cancellation

(defn cancel!
  "Cancel the promise."
  [p]
  (pt/-cancel! p)
  p)

(defn cancelled?
  "Return true if `v` is a cancelled promise."
  [v]
  (pt/-cancelled? v))

;; Completable

(defn resolve!
  "Resolve a completable promise with a value."
  ([o] (pt/-resolve! o nil))
  ([o v] (pt/-resolve! o v)))

(defn reject!
  "Reject a completable promise with an error."
  [p e]
  (pt/-reject! p e))

;; --- Utils

(defn promisify
  "Given a function that accepts a callback as the last argument return other
  function that returns a promise. Callback is expected to take single
  parameter (result of a computation)."
  [callable]
  (fn [& args]
    (create (fn [resolve reject]
               (c/let [args (c/-> (vec args) (conj resolve))]
                 (try
                   (apply callable args)
                   (catch #?(:clj Throwable :cljs js/Error) e
                     (reject e))))))))

#?(:cljs
   (defn ^{:jsdoc ["@constructor"]}
     TimeoutException [message]
     (this-as it
       (.call js/Error it message {} nil)
       it)))

#?(:cljs (goog/inherits TimeoutException js/Error))

(defn timeout
  "Returns a cancellable promise that will be fulfilled with this
  promise's fulfillment value or rejection reason.  However, if this
  promise is not fulfilled or rejected within `ms` milliseconds, the
  returned promise is cancelled with a TimeoutError"
  ([p t] (timeout p t ::default exec/default-scheduler))
  ([p t v] (timeout p t v exec/default-scheduler))
  ([p t v scheduler]
   (c/let [timeout (deferred)
           tid     (exec/schedule! scheduler t #(if (= v ::default)
                                                  (reject! timeout (TimeoutException. "Operation timed out."))
                                                  (resolve! timeout v)))]
     (race [(finally p (fn [_ _] (pt/-cancel! tid))) timeout]))))

(defn delay
  "Given a timeout in miliseconds and optional value, returns a promise
  that will fulfilled with provided value (or nil) after the time is
  reached."
  ([t] (delay t nil exec/default-scheduler))
  ([t v] (delay t v exec/default-scheduler))
  ([t v scheduler]
   (c/let [d (deferred)]
     (exec/schedule! scheduler t #(resolve! d v))
     d)))

(defmacro do!
  "Execute potentially side effectful code and return a promise resolved
  to the last expression. Always awaiting the result of each
  expression."
  [& exprs]
  `(pt/-bind
    (pt/-promise nil)
    (fn [_#]
      ~(condp = (count exprs)
         0 `(pt/-promise nil)
         1 `(pt/-promise ~(first exprs))
         (reduce (fn [acc e]
                   `(pt/-bind (pt/-promise ~e) (fn [_#] ~acc)))
                 `(pt/-promise ~(last exprs))
                 (reverse (butlast exprs)))))))


(defmacro do
  "An alias for do!"
  [& exprs]
  `(do! ~@exprs))

(defmacro let
  "A `let` alternative that always returns promise and waits for all the
  promises on the bindings."
  [bindings & body]
  `(pt/-bind
    (pt/-promise nil)
    (fn [_#]
      ~(c/->> (reverse (partition 2 bindings))
              (reduce (fn [acc [l r]]
                        `(pt/-bind (pt/-promise ~r) (fn [~l] ~acc)))
                      `(do! ~@body))))))

(defmacro plet
  "A parallel let; executes all the bindings in parallel and when all
  bindings are resolved, executes the body."
  [bindings & body]
  `(pt/-bind
    (pt/-promise nil)
    (fn [_#]
      ~(c/let [bindings (partition 2 bindings)]
         `(c/-> (all ~(mapv second bindings))
                (then (fn [[~@(mapv first bindings)]]
                        (do! ~@body))))))))

(defmacro future
  "Analogous to `clojure.core/future` that returns a promise instance
  instead of the `Future`. Usefull for execute synchronous code in a
  separate thread (also works in cljs)."
  [& body]
  `(c/-> (exec/submit! (fn []
                         (c/let [f# (fn [] ~@body)]
                           (pt/-promise (f#)))))
         (pt/-bind identity)))

(def ^:dynamic *loop-run-fn* exec/run!)

(defmacro loop
  [bindings & body]
  (c/let [bindings (partition 2 2 bindings)
          names (mapv first bindings)
          fvals (mapv second bindings)
          tsym (gensym "loop")
          dsym (gensym "deferred")
          rsym (gensym "run")]
    `(c/let [~rsym *loop-run-fn*
             ~dsym (promesa.core/deferred)
             ~tsym (fn ~tsym [params#]
                     (c/-> (promesa.core/all params#)
                           (promesa.core/then (fn [[~@names]]
                                                ;; (prn "exec" ~@names)
                                                (do! ~@body)))
                           (promesa.core/handle
                            (fn [res# err#]
                              ;; (prn "result" res# err#)
                              (cond
                                (not (nil? err#))
                                (promesa.core/reject! ~dsym err#)

                                (and (map? res#) (= (:type res#) :promesa.core/recur))
                                (do (~rsym (fn [] (~tsym (:args res#))))
                                    nil)

                                :else
                                (promesa.core/resolve! ~dsym res#))))))]
       (~rsym (fn [] (~tsym ~fvals)))
       ~dsym)))

(defmacro recur
  [& args]
  `(array-map :type :promesa.core/recur :args [~@args]))

(defmacro ->
  "Like the clojure.core/->, but it will handle promises in values
  and make sure the next form gets the value realized instead of
  the promise. Example using to fetch data in the browser with CLJS:

  Example:

  (p/-> (js/fetch #js {...}) ; returns a promise
        .-body)

  The result of a thread is a promise that will resolve to the
  end of the thread chain."
  [x & forms]
  (c/let [fns (mapv (fn [arg]
                      (c/let [[f & args] (if (sequential? arg)
                                           arg
                                           (list arg))]
                        `(fn [p#] (~f p# ~@args)))) forms)]
    `(chain (promise ~x) ~@fns)))

(defmacro ->>
  "Like the clojure.core/->>, but it will handle promises in values
  and make sure the next form gets the value realized instead of
  the promise. Example using to fetch data in the browser with CLJS:

  Example:

  (p/->> (js/fetch #js {...}) ; returns a promise
         .-body
         read-string
         (mapv inc)

  The result of a thread is a promise that will resolve to the
  end of the thread chain."
  [x & forms]
  (c/let [fns (mapv (fn [arg]
                      (c/let [[f & args] (if (sequential? arg)
                                           arg
                                           (list arg))]
                        `(fn [p#] (~f ~@args p#)))) forms)]
    `(chain (promise ~x) ~@fns)))

(defmacro as->
  "Like clojure.core/as->, but it will handle promises in values
   and make sure the next form gets the value realized instead of
   the promise."
  [expr name & forms]
  `(let [~name ~expr
         ~@(interleave (repeat name) (butlast forms))]
     ~(if (empty? forms)
        name
        (last forms))))

(defmacro with-redefs
  "Like clojure.core/with-redefs, but it will handle promises in
   body and wait until they resolve or reject before restoring the
   bindings. Useful for mocking async APIs."
  [bindings & body]
  (c/let [names         (take-nth 2 bindings)
          vals          (take-nth 2 (drop 1 bindings))
          orig-val-syms (c/map (comp gensym #(str % "-orig-val__") name) names)
          temp-val-syms (c/map (comp gensym #(str % "-temp-val__") name) names)
          binds         (c/map vector names temp-val-syms)
          resets        (reverse (c/map vector names orig-val-syms))
          bind-value    (if (:ns &env)
                          (fn [[k v]] (list 'set! k v))
                          (fn [[k v]] (list 'alter-var-root (list 'var k) (list 'constantly v))))]
    `(c/let [~@(interleave orig-val-syms names)
             ~@(interleave temp-val-syms vals)]
       ~@(c/map bind-value binds)
       (c/-> (promesa.core/do! ~@body)
             (promesa.core/finally
               (fn [_# _#]
                 ~@(c/map bind-value resets)))))))