yadic.clj

gistfile1.clj

(ns pierrepoint.di
  (:require [clojure.string :as st]
            [potemkin.collections :refer [def-map-type keys*]])
  (:import [java.util NoSuchElementException UUID Map]
           [java.lang.reflect Method]
           [clojure.lang RestFn Fn ArityException IDeref]
           [java.lang AutoCloseable]))

; Utils
; ==================================

(defn has-arity [f arity]
  (if (instance? RestFn f)
    (>= arity (.getRequiredArity f))
    (let [invoke-param-counts (->> (.getDeclaredMethods (class f))
                                   (filter #(= "invoke" (.getName %)))
                                   (map (fn [m] (count (.getParameterTypes m)))))]
      (some #(= % arity) invoke-param-counts))))

(defn valid-activator-fn [f]
  (if (has-arity f 1)
    f
    (throw (IllegalArgumentException. (str "Activator functions are expected to be arity 1, i.e. (fn [container]). "
                                           "Function is not arity 1: " f)))))


; Activator (singular)
; ==================================

(defprotocol Activator
  (activate [this container])
  (close [this instance]))

; Functions
; ----------------------------------

(deftype FnActivator [f]
  Activator
  (activate [this container]
    (f container))
  (close [this instance]
    (when (instance? AutoCloseable instance)
      (.close instance)))

  Object
  (toString [this]
    (str "Function activator using " f)))

(defn fn-activator [f]
  (FnActivator. (valid-activator-fn f)))

(defn to-activator-fn [f container-keys]
  (when-not (has-arity f (count container-keys))
    (throw (IllegalArgumentException. (str "Function is not arity " (count container-keys) ". Cannot create using keys " container-keys " " f))))

  (fn [container]
    (apply f (map container container-keys))))

; IDeref
; ----------------------------------

(deftype DerefActivator [d timeout-ms timeout-val]
  Activator
  (activate [this container]
    (if timeout-ms
      (deref d timeout-ms timeout-val)
      @d))
  (close [this instance]
    (when (instance? AutoCloseable instance)
      (.close instance)))

  Object
  (toString [this]
    (str "DerefActivator using " d)))

(defn deref-activator
  ([d] (DerefActivator. d nil nil))
  ([d timeout-ms timeout-val] (DerefActivator. d timeout-ms timeout-val)))

; Classes
; ----------------------------------

(defn has-param-count [expected]
  #(= expected (count (.getParameterTypes %))))

(defn types-match [parameter-types]
  (fn [m]
    (->> (map vector (.getParameterTypes m) parameter-types) ;zip
         (every? (fn [[needed got]]
                   (.isAssignableFrom needed got))))))

(defn get-constructor [c parameter-types]
  (->> (.getConstructors c)
       (filter (has-param-count (count parameter-types)))
       (filter (types-match parameter-types))
       first))

(deftype ClassActivator [c parameter-keys]
  Activator
  (activate [this container]
    (let [parameters (map #(get container %) parameter-keys)
          parameter-types (vec (map #(or (class %) Object) parameters))
          constructor (get-constructor c parameter-types)]
      (when (nil? constructor)
        (throw (IllegalArgumentException.
                 (str "No constructor of " c " "
                      "takes parameter types " parameter-types " "
                      "from keys " parameter-keys))))
      (.newInstance constructor (to-array parameters))))

  (close [this instance]
    (when (instance? AutoCloseable instance)
      (.close instance)))

  Object
  (toString [this]
    (str c " using " parameter-keys)))

(defn class-activator
  ([c] (class-activator c []))
  ([c parameter-keys]
   (when-not (some (has-param-count (count parameter-keys)) (.getConstructors c))
     (throw (IllegalArgumentException.
              (str "No constructor of " c " takes " (count parameter-keys) " parameters for keys " parameter-keys))))
   (ClassActivator. c parameter-keys)))

; Conversion to activators
; ----------------------------------

(defn as-activator [x]
  (cond (fn? x) (fn-activator x)
        (satisfies? Activator x) x
        (instance? IDeref x) (deref-activator x)
        true (throw (IllegalArgumentException. (str "Cannot create activator from " (class x) " " x)))))

; Activators (plural)
; ==================================

(def-map-type Activators [m]
  (get [this k default-value]
       (get m k default-value))

  (assoc [this k activator]
    (Activators. (assoc m k (as-activator activator))))

  (dissoc [this k]
          (if (contains? this k)
            (Activators. (dissoc m k))
            this))

  (keys [this]
        (keys m)))

(defn create-activators
  ([& keys-and-activators]
   (reduce (fn [m [k activator]]
             (assoc m k activator))
           (Activators. {})
           (partition 2 keys-and-activators))))

(def empty-activators (constantly (create-activators)))

; Container
; ==================================

(def-map-type NotFoundContainer []
  (get [this k default-value]
       (throw (NoSuchElementException. (str "Cannot resolve '" k "'"))))

  (assoc [this key value]
    (throw (UnsupportedOperationException.)))

  (dissoc [this key]
          (throw (UnsupportedOperationException.)))
  (keys [this]
        #{}))

(def not-found-container
  (NotFoundContainer.))

(defn activate* [k activator container]
  (try
    (activate activator container)
    (catch Exception e
           (throw (RuntimeException. (str "Failed to instantiate key '" k "' "
                                          "using activator " (class activator) " " activator)
                                     e)))))

(def-map-type SimpleContainer [parent-container mod cache-atom]
  (get [this k default-value]
       (locking cache-atom
         (if (contains? @cache-atom k)
           (@cache-atom k)
           (let [value (if-let [activator (get mod k default-value)]
                         (activate* k activator this)
                         (parent-container k))]
             (swap! cache-atom #(assoc % k value))
             value))))

  (assoc [this key value]
    (throw (UnsupportedOperationException.)))

  (dissoc [this key]
          (throw (UnsupportedOperationException.)))

  (keys [this]
        (throw (UnsupportedOperationException. "Never call keys on a container. It will instantiate all contents.")))

  AutoCloseable
  (close [this]
         (locking cache-atom
           (doseq [[k realised-instance] @cache-atom]
             ; TODO: Use contains? instead of checking for null, once
             ; potemkin bug #23 is fixed
             (when-let [activator (k mod)]
               (try
                 (close activator realised-instance)
                 (catch Exception e
                        (throw (RuntimeException. (str "Could not close instance " realised-instance " "
                                                       "for key " k "' "
                                                       "using activator " (class activator) " " activator)
                                                  e)))))))))

(defn simple-container
  ([activators]
   (simple-container not-found-container activators))
  ([parent-container activators]
   (assert (map? parent-container) (str "Not a map " parent-container))
   (assert (map? activators) (str "Not a map " activators))
   (SimpleContainer. parent-container activators (atom {}))))


; Decoration
; ==================================

(defn decorating-activator [k old-activator new-activator]
  (fn [container]
    (let [activators-with-old-activator (create-activators k old-activator)
          old-activator-container (simple-container container activators-with-old-activator)]
      (activate (as-activator new-activator) old-activator-container))))

(defn decorate [activators k activator-that-depends-on-original-value]
  (let [old-activator (activators k)
        new-activator (decorating-activator k old-activator activator-that-depends-on-original-value)]
    (assoc activators k new-activator)))


; Module
; ==================================

(defprotocol Module
  (add-application-activators [this activators])
  (add-request-activators [this activators]))

(deftype ConcatModules [modules]
  Module
  (add-application-activators [this activators]
    (reduce (fn [activators module]
              (add-application-activators module activators))
            activators
            modules))
  (add-request-activators [this activators]
    (reduce (fn [activators scope]
              (add-request-activators scope activators))
            activators
            modules)))

(defn concat-modules [& modules]
  (ConcatModules. modules))


(ns pierrepoint.di-test
  (:import [java.util UUID ArrayList]
           [java.lang AutoCloseable])
  (:require [midje.sweet :refer :all]
            [pierrepoint.di :refer :all]))

; Basic
; ==================================

(fact "A container calls activators to create instances"
      (let [activators (create-activators :a (constantly 3))
            container (simple-container activators)]
        (:a container) => 3))

(fact "You cannot add non-activators"
      (create-activators :a "not an activator")
      => (throws IllegalArgumentException))

(fact "Activators can request other dependencies"
      (let [activators (create-activators :a (constantly 3)
                                          :b (fn [r] (* 2 (:a r))))
            container (simple-container activators)]
        (:a container) => 3
        (:b container) => 6))

(fact "Containers call activators lazily"
      (let [a-created (atom false)
            activators (create-activators :a (fn [r] (reset! a-created true) "A")
                                          :b (fn [r] "B"))
            container (simple-container activators)]
        (:b container) => "B"
        @a-created => false))

(fact "Containers cache the results of calling activators"
      (let [activators (create-activators :a (fn [_] (UUID/randomUUID)))
            container (simple-container activators)
            first-value (:a container)]

        (:a container) => first-value))

(fact "Containers are maps, so destructuring works"
      (let [activators (-> (empty-activators)
                           (assoc :a (constantly 3))
                           (assoc :b (fn [{:keys [a]}] (* 5 a)))) ; <--- Destructuring here
            container (simple-container activators)]
        (:b container) => 15))

; Destructors
; ==================================

(fact "Activators can specify destructors, which are called when the container is closed"
      (let [close-was-called-with (atom nil)
            activators (create-activators :a (reify Activator
                                               (activate [this container] "the instance")
                                               (close [this instance]
                                                 (reset! close-was-called-with instance))))
            container (simple-container activators)]
        (:a container) => "the instance"
        (.close container)
        @close-was-called-with => "the instance"))

(fact "Destructors aren't called if the instance isn't realised"
      (let [close-was-called (atom false)
            activators (create-activators :a (reify Activator
                                               (activate [this container] "never activated")
                                               (close [this instance]
                                                 (reset! close-was-called true))))
            container (simple-container activators)]
        (.close container)
        @close-was-called => false))

(deftype ACloseableType [closed-atom]
  AutoCloseable
  (close [this]
    (reset! closed-atom true)))

(fact "Function activators that produce AutoCloseable instances will close the instance"
      (let [close-was-called (atom false)
            activators (create-activators :a (constantly (ACloseableType. close-was-called)))
            container (simple-container activators)]
        (:a container) => truthy
        (.close container)
        @close-was-called => true))

(fact "Container is AutoCloseable, and will be closed when using with-open"
      (let [close-was-called-with (atom nil)
            activators (create-activators :a (reify Activator
                                               (activate [this container] "the instance")
                                               (close [this instance]
                                                 (reset! close-was-called-with instance))))]

        (with-open [container (simple-container activators)]
          (:a container) => "the instance")

        @close-was-called-with => "the instance"))

(fact "Container only closes its own instances"
      (let [close-was-called (atom false)
            parent-activators (create-activators :a (constantly (ACloseableType. close-was-called)))
            parent-container (simple-container parent-activators)
            child-container (simple-container parent-container (empty-activators))]

        (:a child-container) => truthy

        (.close child-container)

        @close-was-called => false))

; Decoration
; ==================================

(fact "Decoration works"
      (let [activators (-> (create-activators :a (constantly "a")
                                              :b (fn [r] (str "b saw " (:a r))))
                           (decorate :a (fn [r] (str "decorated " (:a r)))))
            container (simple-container activators)]
        (:a container) => "decorated a"
        (:b container) => "b saw decorated a"))

; Activation using functions
; ==================================

(fact "to-activator-fn turns any function into an activator function"
      (let [activators (create-activators :a (constantly 3)
                                          :b (constantly 5)
                                          :c (to-activator-fn (fn [a b] (* a b))
                                                              [:a :b]))
            container (simple-container activators)]
        (:c container) => 15))

(fact "to-activator-fn throws exception if function arity doesn't match container keys"
      (create-activators :a (to-activator-fn (fn [a b] nil)
                                             [:a]))
      => (throws IllegalArgumentException))

(fact "functions that aren't arity 1 will be rejected"
      (create-activators :a (fn [a b])) => (throws IllegalArgumentException))

; Activation using IDeref
; ==================================

(fact "IDerefs can be used as activators"
      (let [a-promise (promise)
            activators (create-activators :atom (atom "atom")
                                          :promise a-promise
                                          :delay (delay "delay")
                                          :future (future "future")
                                          :never-returns (deref-activator (future (Thread/sleep 100000000))
                                                                          1
                                                                          "timed-out"))
            container (simple-container activators)]

        (deliver a-promise "promise")

        (:atom container) => "atom"
        (:promise container) => "promise"
        (:delay container) => "delay"
        (:future container) => "future"
        (:never-returns container) => "timed-out"))

; ClassActivator
; ==================================

(fact "Class activators call constructors based on keys and the types of the resolved values of those keys"
      (let [activators (create-activators :values (constantly [1 2 3])
                                          :array-list (class-activator ArrayList [:values]))
            container (simple-container activators)
            ; ArrayList has arity 1 constructors for both int and Collection.
            ; The correct one is picked based on the type of :values
            constructed (:array-list container)]

        (class constructed) => ArrayList
        constructed => [1 2 3]))

(fact "You get a helpful early exception at activator creation time if there are no constructors of the right arity"
      (class-activator ArrayList [:no :matching :constructor :for :this :many])
      => (throws IllegalArgumentException))