spec-dispatch.clj

;; error handling -----------------------------------

(defn check-cyclic-prefs [sd spec specs]
  (assert (not-any? #(contains? (set (get @(:prefs sd) %))
                                spec)
                    specs)
          (str "circular dependency:"
               "\nname: " (:name sd)
               "\nspec:" spec
               "\nconflicts: " (keep #(contains? (set (get @(:prefs sd) %))
                                                 spec)
                                     specs))))


(defn check-opts [opts]
  (assert (instance? clojure.lang.IDeref (:dispatch-map opts (atom {})))
          "dispatch-map must be an atom")
  (assert (instance? clojure.lang.IDeref (:prefs opts (atom {})))
          "prefs must be an atom"))

(defn throw-unresolvable-impl-error [matching-specs]
  (throw (Exception. (str "can't choose an implementation for those matches: "
                          matching-specs
                          "\n you have to specify preferences."))))

;; impl -----------------------------------------------

(defn choose-impl
  "resolve cases where multiple specs matches"
  [prefs matches]
  (let [matching-specs (set (keys matches))

        concerned-prefs
        (into {} (filter (comp matching-specs key) prefs))

        [chosen-spec]
        (filter (fn [spec]
                  (every? (get concerned-prefs spec (constantly false))
                          (disj matching-specs spec)))
                matching-specs)]
    (if chosen-spec
      (get matches chosen-spec)
      (throw-unresolvable-impl-error matching-specs))))

(defrecord SpecDispatcher [name dispatch-map prefs]
  clojure.lang.IFn
  (invoke [this a1]
    (let [matches (into {}
                        (filter (fn [[spec impl]]
                                  (try (cs/valid? spec a1)
                                       (catch Exception e nil)))
                                @dispatch-map))]
      (condp = (count matches)
        0 (throw (Exception. (str "No implementation for: " a1)))
        1 ((-> matches first val) a1)
        ((choose-impl @prefs matches) a1)))))

;; API ----------------------------------------------------------

(defn prefer! [sd spec & specs]
  (check-cyclic-prefs sd spec specs)
  (swap! (:prefs sd) (fn [xs] (into (set xs) specs)))
  sd)

(defn unprefer! [sd spec & specs]
  (swap! (:prefs sd) (fn [xs] (apply disj (set xs) specs)))
  sd)

(defn add-impl! [sd spec impl]
  (swap! (:dispatch-map sd) assoc spec impl)
  sd)

(defn rem-impl! [sd spec]
  (swap! (:dispatch-map sd) dissoc spec)
  sd)

(defn default-opts []
  {:name (gensym)
   :dispatch-map (atom {})
   :prefs (atom {})})

(defn sdf
  ([opts]
   (check-opts opts)
   (map->SpecDispatcher
     (merge (default-opts) opts)))
  ([name dm prefs]
    (SpecDispatcher. name dm prefs)))

;; tests ------------------------------------------------------

(def f (sdf
          {:name :sd
           :dispatch-map
           (atom
             {int? (fn [x] :int-case)
              even? (fn [x] :even-case)
              ident? (fn [x] :ident-case)
              keyword? (fn [x] :kw-case)})
           :prefs
           (atom {even? #{int?}})}))

(comment
  (f 2)
  (f 1)
  (f 'foo)
  (f :foo)
  (f []))