(ns docker-clojure.core-test
  (:require [clojure.test :refer :all]
            [docker-clojure.core :refer :all]
            [clojure.string :as str]))

(deftest image-variants-test
  (testing "generates the expected set of variants"
    (with-redefs [default-distro (constantly :debian/slim-buster)]
      (let [variants (image-variants #{8 11 14 15}
                                     #{:debian/buster :debian/slim-buster :alpine/alpine}
                                     {"lein"       "2.9.1"
                                      "boot"       "2.8.3"
                                      "tools-deps" "1.10.1.478"})]
        ;; filter is to make failure output a little more humane
        (are [v] (contains? (->> variants
                                 (filter #(and (= (:jdk-version %) (:jdk-version v))
                                               (= (:distro %) (:distro v))
                                               (= (:build-tool %) (:build-tool v))))
                                 set)
                            v)
                 {:jdk-version 11, :distro :debian/slim-buster, :build-tool "lein"
                  :base-image  "openjdk:11-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "lein-2.9.1", :build-tool-version "2.9.1"}
                 {:jdk-version 11, :distro :debian/slim-buster, :build-tool "boot"
                  :base-image  "openjdk:11-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "boot-2.8.3", :build-tool-version "2.8.3"}
                 {:jdk-version        11, :distro :debian/slim-buster
                  :base-image         "openjdk:11-slim-buster"
                  :build-tool         "tools-deps"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "tools-deps-1.10.1.478"
                  :build-tool-version "1.10.1.478"}
                 {:jdk-version 11, :distro :debian/buster, :build-tool "lein"
                  :base-image  "openjdk:11-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "lein-2.9.1-buster", :build-tool-version "2.9.1"}
                 {:jdk-version 11, :distro :debian/buster, :build-tool "boot"
                  :base-image  "openjdk:11-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "boot-2.8.3-buster", :build-tool-version "2.8.3"}
                 {:jdk-version        11, :distro :debian/buster
                  :base-image         "openjdk:11-buster"
                  :build-tool         "tools-deps"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "tools-deps-1.10.1.478-buster"
                  :build-tool-version "1.10.1.478"}
                 {:jdk-version 8, :distro :debian/slim-buster, :build-tool "lein"
                  :base-image  "openjdk:8-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "openjdk-8-lein-2.9.1", :build-tool-version "2.9.1"}
                 {:jdk-version 8, :distro :debian/slim-buster, :build-tool "boot"
                  :base-image  "openjdk:8-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "openjdk-8-boot-2.8.3", :build-tool-version "2.8.3"}
                 {:jdk-version        8, :distro :debian/slim-buster
                  :build-tool         "tools-deps"
                  :base-image         "openjdk:8-slim-buster"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-8-tools-deps-1.10.1.478"
                  :build-tool-version "1.10.1.478"}
                 {:jdk-version        14, :distro :debian/slim-buster, :build-tool "lein"
                  :base-image         "openjdk:14-slim-buster"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-14-lein-2.9.1"
                  :build-tool-version "2.9.1"}
                 {:jdk-version        15, :distro :alpine/alpine, :build-tool "lein"
                  :base-image         "openjdk:15-alpine"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-15-lein-2.9.1-alpine"
                  :build-tool-version "2.9.1"}
                 {:jdk-version        15, :distro :alpine/alpine, :build-tool "boot"
                  :base-image         "openjdk:15-alpine"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-15-boot-2.8.3-alpine"
                  :build-tool-version "2.8.3"}
                 {:jdk-version        15, :distro :alpine/alpine
                  :base-image         "openjdk:15-alpine"
                  :build-tool         "tools-deps"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-15-tools-deps-1.10.1.478-alpine"
                  :build-tool-version "1.10.1.478"})))))

(deftest variant-map-test
  (testing "returns the expected map version of the image variant list"
    (is (= {:jdk-version        8
            :base-image         "openjdk:8-distro"
            :distro             :distro/distro
            :build-tool         "build-tool"
            :docker-tag         "openjdk-8-build-tool-1.2.3-distro"
            :build-tool-version "1.2.3"
            :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"}
           (variant-map '(8 :distro/distro ["build-tool" "1.2.3"]))))))

(deftest exclude?-test
  (testing "excludes variant that matches all key-values in any exclusion"
    (is (exclude? #{{:base-image "bad"}
                    {:base-image "not-great", :build-tool "woof"}}
                  {:base-image         "not-great" :build-tool "woof"
                   :build-tool-version "1.2.3"})))
  (testing "does not exclude partial matches"
    (is (not (exclude? #{{:base-image "bad", :build-tool "woof"}}
                       {:base-image "bad", :build-tool "boot"})))))

(deftest docker-tag-test
  (with-redefs [default-jdk-version 11                      ; TODO: Make this an arg to the fn instead
                default-distro (constantly :debian/slim-buster)] ; TODO: Rethink this too?
    (testing "default java version is left out"
      (is (not (str/includes? (docker-tag {:jdk-version 11})
                              "openjdk-11"))))
    (testing "non-default version is added as a prefix"
      (is (str/starts-with? (docker-tag {:jdk-version 14})
                            "openjdk-14")))
    (testing "default distro is left out"
      (is (not (str/includes? (docker-tag {:jdk-version 14
                                           :distro      :debian/slim-buster})
                              "slim-buster"))))
    (testing "alpine is added as a suffix"
      (is (str/ends-with? (docker-tag {:jdk-version 8
                                       :distro      :alpine/alpine})
                          "alpine")))
    (testing "build tool is included"
      (is (str/includes? (docker-tag {:jdk-version 11
                                      :build-tool  "lein"})
                         "lein")))
    (testing "build tool version is included"
      (is (str/includes? (docker-tag {:jdk-version        11
                                      :build-tool         "boot"
                                      :build-tool-version "2.8.1"})
                         "2.8.1")))))

(ns docker-clojure.core-test
  (:require [clojure.test :refer :all]
            [docker-clojure.core :refer :all]
            [clojure.string :as str]))

(deftest image-variants-test
  (testing "generates the expected set of variants"
    (with-redefs [default-distro (constantly :debian/slim-buster)
                  default-jdk-version 11]
      (let [variants (image-variants #{8 11 14 15}
                                     #{:debian/buster :debian/slim-buster :alpine/alpine}
                                     {"lein"       "2.9.1"
                                      "boot"       "2.8.3"
                                      "tools-deps" "1.10.1.478"})]
        ;; filter is to make failure output a little more humane
        (are [v] (contains? (->> variants
                                 (filter #(and (= (:jdk-version %) (:jdk-version v))
                                               (= (:distro %) (:distro v))
                                               (= (:build-tool %) (:build-tool v))))
                                 set)
                            v)
                 {:jdk-version 11, :distro :debian/slim-buster, :build-tool "lein"
                  :base-image  "openjdk:11-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "lein-2.9.1", :build-tool-version "2.9.1"}
                 {:jdk-version 11, :distro :debian/slim-buster, :build-tool "boot"
                  :base-image  "openjdk:11-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "boot-2.8.3", :build-tool-version "2.8.3"}
                 {:jdk-version        11, :distro :debian/slim-buster
                  :base-image         "openjdk:11-slim-buster"
                  :build-tool         "tools-deps"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "tools-deps-1.10.1.478"
                  :build-tool-version "1.10.1.478"}
                 {:jdk-version 11, :distro :debian/buster, :build-tool "lein"
                  :base-image  "openjdk:11-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "lein-2.9.1-buster", :build-tool-version "2.9.1"}
                 {:jdk-version 11, :distro :debian/buster, :build-tool "boot"
                  :base-image  "openjdk:11-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "boot-2.8.3-buster", :build-tool-version "2.8.3"}
                 {:jdk-version        11, :distro :debian/buster
                  :base-image         "openjdk:11-buster"
                  :build-tool         "tools-deps"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "tools-deps-1.10.1.478-buster"
                  :build-tool-version "1.10.1.478"}
                 {:jdk-version 8, :distro :debian/slim-buster, :build-tool "lein"
                  :base-image  "openjdk:8-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "openjdk-8-lein-2.9.1", :build-tool-version "2.9.1"}
                 {:jdk-version 8, :distro :debian/slim-buster, :build-tool "boot"
                  :base-image  "openjdk:8-slim-buster"
                  :maintainer  "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag  "openjdk-8-boot-2.8.3", :build-tool-version "2.8.3"}
                 {:jdk-version        8, :distro :debian/slim-buster
                  :build-tool         "tools-deps"
                  :base-image         "openjdk:8-slim-buster"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-8-tools-deps-1.10.1.478"
                  :build-tool-version "1.10.1.478"}
                 {:jdk-version        14, :distro :debian/slim-buster, :build-tool "lein"
                  :base-image         "openjdk:14-slim-buster"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-14-lein-2.9.1"
                  :build-tool-version "2.9.1"}
                 {:jdk-version        15, :distro :alpine/alpine, :build-tool "lein"
                  :base-image         "openjdk:15-alpine"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-15-lein-2.9.1-alpine"
                  :build-tool-version "2.9.1"}
                 {:jdk-version        15, :distro :alpine/alpine, :build-tool "boot"
                  :base-image         "openjdk:15-alpine"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-15-boot-2.8.3-alpine"
                  :build-tool-version "2.8.3"}
                 {:jdk-version        15, :distro :alpine/alpine
                  :base-image         "openjdk:15-alpine"
                  :build-tool         "tools-deps"
                  :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"
                  :docker-tag         "openjdk-15-tools-deps-1.10.1.478-alpine"
                  :build-tool-version "1.10.1.478"})))))

(deftest variant-map-test
  (testing "returns the expected map version of the image variant list"
    (is (= {:jdk-version        8
            :base-image         "openjdk:8-distro"
            :distro             :distro/distro
            :build-tool         "build-tool"
            :docker-tag         "openjdk-8-build-tool-1.2.3-distro"
            :build-tool-version "1.2.3"
            :maintainer         "Paul Lam <paul@quantisan.com> & Wes Morgan <wesmorgan@icloud.com>"}
           (variant-map '(8 :distro/distro ["build-tool" "1.2.3"]))))))

(deftest exclude?-test
  (testing "excludes variant that matches all key-values in any exclusion"
    (is (exclude? #{{:base-image "bad"}
                    {:base-image "not-great", :build-tool "woof"}}
                  {:base-image         "not-great" :build-tool "woof"
                   :build-tool-version "1.2.3"})))
  (testing "does not exclude partial matches"
    (is (not (exclude? #{{:base-image "bad", :build-tool "woof"}}
                       {:base-image "bad", :build-tool "boot"})))))

(deftest docker-tag-test
  (with-redefs [default-jdk-version 11                      ; TODO: Make this an arg to the fn instead
                default-distro (constantly :debian/slim-buster)] ; TODO: Rethink this too?
    (testing "default java version is left out"
      (is (not (str/includes? (docker-tag {:jdk-version 11})
                              "openjdk-11"))))
    (testing "non-default version is added as a prefix"
      (is (str/starts-with? (docker-tag {:jdk-version 14})
                            "openjdk-14")))
    (testing "default distro is left out"
      (is (not (str/includes? (docker-tag {:jdk-version 14
                                           :distro      :debian/slim-buster})
                              "slim-buster"))))
    (testing "alpine is added as a suffix"
      (is (str/ends-with? (docker-tag {:jdk-version 8
                                       :distro      :alpine/alpine})
                          "alpine")))
    (testing "build tool is included"
      (is (str/includes? (docker-tag {:jdk-version 11
                                      :build-tool  "lein"})
                         "lein")))
    (testing "build tool version is included"
      (is (str/includes? (docker-tag {:jdk-version        11
                                      :build-tool         "boot"
                                      :build-tool-version "2.8.1"})
                         "2.8.1")))))

Fix tests

Fix tests

Need to remove these with-redefs one of these days...


(ns constraint.edit
  (:require [constraint.common :refer [edge-id]]))

(def edge-id-len (count edge-id))

(defn where-svg-was-clicked [event]
  (let [svg-rect (.getBoundingClientRect (dommy.core/sel1 :svg))
        click-position [(.-clientX event) (.-clientY event)]
        rect-position [(.-left svg-rect) (.-top svg-rect)]]
    (map - click-position rect-position)))

(defn move-the-vertex [world-state event]
  (let [moving (:selected world-state)
        position-to-update [:vertices moving 1]
        where (where-svg-was-clicked event)]
    (update-in world-state position-to-update (constantly where))))

(defn get-key [edge-str]
  (->> edge-str
       (drop edge-id-len)
       (apply str)
       (js/parseInt)))

(defn largest-key [{:keys [edges]}]
  (-> (map get-key (keys edges))
      (sort)
      (reverse)
      (first)))

(defn next-key [key-num]
  (str edge-id (inc key-num)))

(defn first-connected-edge [from to {:keys [edges]}]
  (let [connected-either-way? #{[from to] [to from]}
        get-edge-ends (comp butlast second)
        connected? (comp connected-either-way? get-edge-ends)]
    (first (filter connected? edges))))

(defn make-new-edge [from to world-state]
  (let [next-to-largest-key (next-key (largest-key world-state))]
    [next-to-largest-key [from to :red]])
  )

(defn add-or-delete-edge [from to world-state]
  (let [connected-id (first (first-connected-edge from to world-state))
        add-new-edge #(conj % (make-new-edge from to world-state))
        delete-edge #(dissoc % connected-id)
        add-or-delete (if (nil? connected-id) add-new-edge delete-edge)]
    (update-in world-state [:edges] add-or-delete)))

(defn edit-vertex-or-connections [clicked-vertex world-state]
  (let [selected (:selected world-state)
        swap-vertex-size #(inc (mod % 2))
        selected-vertex-size [:vertices selected 0]]
    (if (= selected clicked-vertex)
      (update-in world-state selected-vertex-size swap-vertex-size)
      (add-or-delete-edge selected clicked-vertex world-state)
      )))

(defn handle-editing [clicked-what event world-state]
  (let [clicked-edge? (re-matches #"edge.*" clicked-what)
        clicked-vertex? (re-matches #"vertex.*" clicked-what)]
    (if (:selected world-state)
      (merge (if clicked-vertex?
               (edit-vertex-or-connections clicked-what world-state)
               (move-the-vertex world-state event))
        {:selected nil})
      (cond
        clicked-edge? (update-in world-state [:edges clicked-what 2]
                                 #(if (= :blue %) :red :blue))
        clicked-vertex? (merge world-state {:selected clicked-what})
        :else world-state))))

(ns constraint.edit
  (:require [constraint.common :refer [edge-id]]))

(def edge-id-len (count edge-id))

(defn where-svg-was-clicked [event]
  (let [svg-rect (.getBoundingClientRect (dommy.core/sel1 :svg))
        click-position [(.-clientX event) (.-clientY event)]
        rect-position [(.-left svg-rect) (.-top svg-rect)]]
    (map - click-position rect-position)))

(defn move-the-vertex [world-state event]
  (let [moving (:selected world-state)
        position-to-update [:vertices moving 1]
        where (where-svg-was-clicked event)]
    (update-in world-state position-to-update (constantly where))))

(defn get-key [edge-str]
  (->> edge-str
       (drop edge-id-len)
       (apply str)
       (js/parseInt)))

(defn largest-key [{:keys [edges]}]
  (-> (map get-key (keys edges))
      (sort)
      (reverse)
      (first)))

(defn next-key [key-num]
  (str edge-id (inc key-num)))

(defn first-connected-edge [from to {:keys [edges]}]
  (let [connected-either-way? #{[from to] [to from]}
        get-edge-ends (comp butlast second)
        connected? (comp connected-either-way? get-edge-ends)]
    (first (filter connected? edges))))

(defn make-new-edge [from to world-state]
  (let [next-to-largest-key (next-key (largest-key world-state))]
    [next-to-largest-key [from to :red]])
  )

(defn add-or-delete-edge [from to world-state]
  (let [connected-id (first (first-connected-edge from to world-state))
        add-new-edge #(conj % (make-new-edge from to world-state))
        delete-edge #(dissoc % connected-id)
        add-or-delete (if (nil? connected-id) add-new-edge delete-edge)]
    (update-in world-state [:edges] add-or-delete)))

(defn toggle-vertex-size [selected world-state]
  (let [toggle-between-sizes #(inc (mod % 2))
        selected-vertex-size [:vertices selected 0]]
    (update-in world-state
               selected-vertex-size
               toggle-between-sizes)))

(defn edit-vertex-or-connections [clicked-vertex world-state]
  (let [selected (:selected world-state)]
    (if (= selected clicked-vertex)
      (toggle-vertex-size selected world-state)
      (add-or-delete-edge selected clicked-vertex world-state))))

(defn handle-editing [clicked-what event world-state]
  (let [clicked-edge? (re-matches #"edge.*" clicked-what)
        clicked-vertex? (re-matches #"vertex.*" clicked-what)]
    (if (:selected world-state)
      (merge (if clicked-vertex?
               (edit-vertex-or-connections clicked-what world-state)
               (move-the-vertex world-state event))
        {:selected nil})
      (cond
        clicked-edge? (update-in world-state [:edges clicked-what 2]
                                 #(if (= :blue %) :red :blue))
        clicked-vertex? (merge world-state {:selected clicked-what})
        :else world-state))))

Detach size toggle from edit-vertex-or-connections


(ns com.nomistech.clojure-the-language.clojure-numerics-test
  (:require [midje.sweet :refer :all]))

;;;; ___________________________________________________________________________
;;;; ---- Terminology ----

;; The phrase "equivalent value" is used when two numbers, possibly of
;; different types, are the same value as seen from the point of view of
;; mathematics. So, for example, 2 and 2.0 are equivalent values.

;;;; ___________________________________________________________________________
;;;; ---- Clojure's numeric types ----

(fact "Some of Clojure's numeric types are from java.lang"
  (fact (= Byte    java.lang.Byte)    => true)
  (fact (= Short   java.lang.Short)   => true)
  (fact (= Integer java.lang.Integer) => true)
  (fact (= Long    java.lang.Long)    => true)
  (fact (= Float   java.lang.Float)   => true)
  (fact (= Double  java.lang.Double)  => true))

(fact "Some of Clojure's numeric types are from java.math"
  (fact (= BigDecimal java.math.BigDecimal) => true)
  (fact (= BigInteger java.math.BigInteger) => true))

(fact "Some of Clojure's numeric types are from clojure.lang"
  ;; These are not available without the clojure.lang. prefix.
  (fact clojure.lang.BigInt => clojure.lang.BigInt)
  (fact clojure.lang.Ratio  => clojure.lang.Ratio))

(fact "Some examples of values of each type"
  (fact (type 2)     => Long)
  (fact (type 2N)    => clojure.lang.BigInt)
  (fact (type 2/3)   => clojure.lang.Ratio)
  (fact (type 2.0M)  => BigDecimal)
  (fact (type 2M)    => BigDecimal)
  (fact (type 2.0)   => Double)
  (fact (type (Byte. (byte 2)))     => Byte)
  (fact (type (Short. (short 2)))   => Short)
  (fact (type (Integer. (int 2)))   => Integer)
  (fact (type (BigInteger. "2"))    => BigInteger)
  (fact (type (Float. (float 2.0))) => Float))

(fact "Autoboxing when calling a function"
  (fact (type (byte 2))    => Byte)
  (fact (type (short 2))   => Short)
  (fact (type (int 2))     => Integer)
  (fact (type (long 2))    => Long)
  (fact (type (float 2.0)) => Float))

(fact "Ratios are turned into Longs if possible"
  (type 4/2) => Long)

;; From /Clojure Programming/, p427: "double is the only representation that
;; is inherently inexact".

;;;; ___________________________________________________________________________
;;;; ---- `identical?` ----
;;;; The doc string:
;;;;   Tests whether two arguments are the same object.

;; /Clojure Programming/ p433 says:
;;   In general, numbers will never be identical?, even if provided as
;;   literals.

(fact "In general, two numbers created from two same-looking literals are not identical"
  (fact (identical? 2000 2000) => false)
  (fact (identical? 2N 2N)     => false)
  (fact (identical? 2/3 2/3)   => false)
  (fact (identical? 2M 2M)     => false)
  (fact (identical? 2.0M 2.0M) => false)
  (fact (identical? 2.0 2.0)   => false))

(fact "2 is identical to 2, which seems to contradict the statement that numbers will never be identical, but remember the 'in general'"
  (identical? 2 2) => true)

(fact "Same-valued fixnums are identical to each other, but same-valued non-fixnums are not identical to each other"
  ;; Explained by /Clojure Programming/ p433 which says:
  ;;   The exception is that the JVM (and therefore Clojure) provides for a
  ;;   limited range of fixnums. Fixnums are a pool of boxed integer values
  ;;   that are always used in preference to allocating a new integer. [...]
  ;;   The Oracle JVM’s fixnum range is ±127.
  ;;     jsk: Actually -128 to +127
  (fact (identical? -129 -129) => false)
  (fact (identical? -128 -128) => true)
  (fact (identical?  127  127) => true)
  (fact (identical?  128  128) => false))

(fact "But, of course, a number object is identical to itself"
  (let [x 2N] (identical? x x)) => true)

(fact "And, of course, numbers with different representations are not identical"
  (fact (identical? 2 2N)   => false)
  (fact (identical? 2 2M)   => false)
  (fact (identical? 2 2.0M) => false)
  (fact (identical? 2 2.0)  => false))

;;;; ___________________________________________________________________________
;;;; ---- `=` ----
;;;; The doc string:
;;;;   Equality. Returns true if x equals y, false if not. Same as Java
;;;;   x.equals(y) except it also works for nil, and compares numbers and
;;;;   collections in a type-independent manner. Clojure's immutable data
;;;;   structures define equals() (and thus =) as a value, not an identity,
;;;;   comparison.

;; I think there's a problem with the doc string:
;; - What does it mean by "in a type-independent manner"?
;;   - Is this defined in any authoritative place?
;;   - The doc string for `==` uses the phrase "type-independent" with a
;;     different (and, to me, intuitive) meaning.
;; - I would expect e.g. (= 2 2M) => true, but that's not so.
;;   - I'm not the only one:
;;     - See http://dev.clojure.org/jira/browse/CLJ-1333.

;; Jeez, Clojure is poorly specified in places.

;; /Clojure Programming/ p433-444 was helpful.

;; We need the notion of categories of numbers. (Is this defined in any
;; authoritative place?)
;; - We have:
;;   - integers (e.g. 2, 2N)
;;   - ratios (e.g. 2/3)
;;   - arbitrary-precision decimals (e.g. 2M, 2.0M)
;;   - limited-precision decimals (e.g. 2.0, (Float. 2.0))

;;;; ---------------------------------------------------------------------------
;;;; ---- Things that are fine ----

(fact "All types of integer are usefully comparable using `=`"
  ;; From /Clojure Programming/ with adjustments
  (= (Byte. (byte 2))
     (Short. (short 2))
     (Integer. (int 2))
     2
     2N)
  => true)

(fact "Ratios are usefully comparable using `=`"
  (= 2/3 2/3)
  => true)

(fact "Arbitrary-precision decimals are usefully comparable using `=`"
  (= 1.25M
     1.25M)
  => true)

(fact "Limited-precision decimals of different widths are usefully comparable using `=`"
  ;; From /Clojure Programming/
  (= 1.25 ; a Double
     (Float. 1.25))
  => true)

;;;; ---------------------------------------------------------------------------
;;;; ---- The thing that is, in my opinion, contrary to the doc string ----

(fact "`=` returns false for comparisons of equivalent numbers of different categories"
  ;; From /Clojure Programming/ with some changes and additions
  (fact (= 2 2.0)    => false)
  (fact (= 2 2M)     => false)
  (fact (= 2N 2M)    => false)
  (fact (= 1.25 5/4) => false))

;; From /Clojure Programming/:
;;   Clojure’s `=` could obviate these type differences (as Ruby and Python
;;   do), but doing so would impose some runtime cost that would be
;;   unappreciated by those who need to maximize the performance of programs
;;   that work with homogeneous numeric data.

;;;; ---------------------------------------------------------------------------
;;;; ---- My playing ----

;; Shows that "same category" is A Thing, as /Clojure Programming/ says. Shows
;; that the doc string's "type-independent manner" is wrong (according to what
;; I think that should mean).

;; Summary, showing the equivalence classes apart from Ratios:
;;;
;;   Key to the table entries:
;;;
;;         =   means   (= x y) is true
;;         .   means   (= x y) is false
;;             where x is the row value and y is the column value
;;;
;;       F2.0  means   (Float. 2.0)
;;;
;;
;;              --------------------------------------
;;        =     |   2  2N   |  2M 2.0M  |  2.0  F2.0 |
;;     -----------------------------------------------
;;     |        |           |           |            |
;;     |  2     |   =   =   |   .   .   |   .   .    |
;;     |        |           |           |            |
;;     |  2N    |   =   =   |   .   .   |   .   .    |
;;     |        |           |           |            |
;;     -----------------------------------------------
;;     |        |           |           |            |
;;     |  2M    |   .   .   |   =   =   |   .   .    |
;;     |        |           |           |            |
;;     |  2.0M  |   .   .   |   =   =   |   .   .    |
;;     |        |           |           |            |
;;     -----------------------------------------------
;;     |        |           |           |            |
;;     |  2.0   |   .   .   |   .   .   |   =   =    |
;;     |        |           |           |            |
;;     |  F2.0  |   .   .   |   .   .   |   =   =    |
;;     |        |           |           |            |
;;     -----------------------------------------------

(fact "Two numbers of the same type and with equivalent value are equal using `=`"
  (fact (= 2 2)                       => true)
  (fact (= 2N 2N)                     => true)
  (fact (= 2/3 2/3)                   => true)
  (fact (= 2M 2M)                     => true)
  (fact (= 2.0M 2.0M)                 => true)
  (fact (= 2.0 2.0)                   => true)
  (fact (= (Float. 2.0) (Float. 2.0)) => true))

(fact "Two numbers of the same category and with equivalent value are equal using `=`"
  (fact (= 2   2N)           => true)
  (fact (= 2M  2.0M)         => true)
  (fact (= 2.0 (Float. 2.0)) => true))

(fact "Two numbers of different categories are not equal using `=`"
  (fact (= 2    2M)            => false)
  (fact (= 2    2.0M)          => false)
  (fact (= 2    2.0)           => false)
  (fact (= 2    (Float. 2.0))  => false)
  ;;
  (fact (= 2N   2M)            => false)
  (fact (= 2N   2.0M)          => false)
  (fact (= 2N   2.0)           => false)
  (fact (= 2N   (Float. 2.0))  => false)
  ;;
  (fact (= 2M   2.0)           => false)
  (fact (= 2M   (Float. 2.0))  => false)
  ;;
  (fact (= 2.0M 2.0)           => false)
  (fact (= 2.0M (Float. 2.0))  => false))

;;;; ---------------------------------------------------------------------------

(fact "Collections use `=` to determine equality"
  (into #{} [(Byte. (byte 2))
             (Short. (short 2))
             (Integer. (int 2))
             2
             2N
             2M
             2.0M
             2.0
             (Float. 2.0)])
  => #{2 2.0M 2.0})

;;;; ___________________________________________________________________________
;;;; ---- `==` ----
;;;; The doc string:
;;;;   Returns non-nil if nums all have the equivalent value (type-independent),
;;;;   otherwise false.

;; The doc string uses the phrase "type-independent" in a way that is (to me)
;; intuitive, but which has a different meaning to that in the doc string for
;; `=`.

;; From /Clojure Programming/:
;;   Clojure opts to provide a third notion of equality, specifically to
;;   address the need for type-insensitive equivalence tests.

(fact "Numbers with an equivalent value are equal using `==`"
  (== (Byte. (byte 2))
      (Short. (short 2))
      (Integer. (int 2))
      2
      2N
      2M
      2.0M
      2.0
      (Float. 2.0))
  => true)

;;;; ___________________________________________________________________________
;;;; ---- Going from Longs to BigInts and vice versa, or not ----

(def max-long-plus-1 9223372036854775808N)

(fact "About the 'ordinary' arithmetic operators"
  ;;
  (fact "Throw exceptions on overflow"
    (inc Long/MAX_VALUE)
    => (throws ArithmeticException "integer overflow"))
  ;;
  (fact "We can avoid overflow exceptions by coercing to BigInt first"
    (inc (bigint Long/MAX_VALUE))
    => max-long-plus-1)
  ;;
  (fact "Do not demote from BigInt"
    (type (- max-long-plus-1 Long/MAX_VALUE))
    => clojure.lang.BigInt))

(fact "About the xxxx' operators"
  ;;
  (fact "Auto-promote"
    (inc' Long/MAX_VALUE)
    => max-long-plus-1)
  ;;
  (fact "Do not promote if unnecessary"
    (type (inc' 1))
    => Long)
  ;;
  (fact "Do not demote"
    (type (dec' (inc' Long/MAX_VALUE)))
    => clojure.lang.BigInt))

(def boxed-max-long Long/MAX_VALUE)

(fact "About the unchecked-xxxx operators"
  ;;
  (fact "Don't check for overflow"
    (unchecked-inc Long/MAX_VALUE)
    => Long/MIN_VALUE)
  ;;
  (fact "Only do what you expect on longs, not Longs"
    ;; The doc strings for unchecked operations only define what happens
    ;; for (unboxed) longs, not for (boxed) Longs.
    ;; - See https://groups.google.com/d/msg/clojure/1tefVmYKmpc/2hKlXU-c13sJ
    (fact "With a boxed value it seems weird"
      (unchecked-inc boxed-max-long)
      => (throws ArithmeticException "integer overflow"))
    (fact "But with an unboxed value it's as you'd expect"
      (let [unboxed-max-long Long/MAX_VALUE]
        (unchecked-inc unboxed-max-long))
      => Long/MIN_VALUE)))

;;;; ___________________________________________________________________________
;;;; ---- Some things about BigInts and Ratios ----

(fact "About the ratio of a BigInt and a Long-or-a-BigInt"
  (let [an-even-big-int (+' Long/MAX_VALUE 1)
        an-odd-big-int  (+' Long/MAX_VALUE 2)]
    (assert (even? an-even-big-int))
    (assert (odd?  an-odd-big-int))
    (assert (= (type an-even-big-int) clojure.lang.BigInt))
    (assert (= (type an-odd-big-int)  clojure.lang.BigInt))
    (fact "If the ratio is an integer it is a BigInt"
      (type (/ an-even-big-int 2))  => clojure.lang.BigInt
      (type (/ an-even-big-int 2N)) => clojure.lang.BigInt)
    (fact "If ratio is not an integer it is a Ratio"
      (type (/ an-odd-big-int 2))   => clojure.lang.Ratio
      (type (/ an-odd-big-int 2N))  => clojure.lang.Ratio)))

(ns com.nomistech.clojure-the-language.clojure-numerics-test
  (:require [midje.sweet :refer :all]))

;;;; ___________________________________________________________________________
;;;; ---- Terminology ----

;; The phrase "equivalent value" is used when two numbers, possibly of
;; different types, are the same value as seen from the point of view of
;; mathematics. So, for example, 2 and 2.0 are equivalent values.

;;;; ___________________________________________________________________________
;;;; ---- Clojure's numeric types ----

(fact "Some of Clojure's numeric types are from java.lang"
  (fact (= Byte    java.lang.Byte)    => true)
  (fact (= Short   java.lang.Short)   => true)
  (fact (= Integer java.lang.Integer) => true)
  (fact (= Long    java.lang.Long)    => true)
  (fact (= Float   java.lang.Float)   => true)
  (fact (= Double  java.lang.Double)  => true))

(fact "Some of Clojure's numeric types are from java.math"
  (fact (= BigDecimal java.math.BigDecimal) => true)
  (fact (= BigInteger java.math.BigInteger) => true))

(fact "Some of Clojure's numeric types are from clojure.lang"
  ;; These are not available without the clojure.lang. prefix.
  (fact clojure.lang.BigInt => clojure.lang.BigInt)
  (fact clojure.lang.Ratio  => clojure.lang.Ratio))

(fact "We can produce unboxed values"
  ;; **** Is there a way to make a test of this?
  (byte 2)
  (short 2)
  (int 2)
  (float 2.2)
  (double 2.2))

(fact "Some examples of values that have literal representations"
  (fact (type 2)     => Long)
  (fact (type 2N)    => clojure.lang.BigInt)
  (fact (type 2/3)   => clojure.lang.Ratio)
  (fact (type 2.0M)  => BigDecimal)
  (fact (type 2M)    => BigDecimal)
  (fact (type 2.0)   => Double))

(fact "Some examples of values that do not have literal representations"
  (fact (type (Byte. (byte 2)))     => Byte)
  (fact (type (Short. (short 2)))   => Short)
  (fact (type (Integer. (int 2)))   => Integer)
  (fact (type (BigInteger. "2"))    => BigInteger)
  (fact (type (Float. (float 2.0))) => Float))

(fact "Autoboxing when calling a function"
  (fact (type (byte 2))    => Byte)
  (fact (type (short 2))   => Short)
  (fact (type (int 2))     => Integer)
  (fact (type (long 2))    => Long)
  (fact (type (float 2.0)) => Float))

(fact "Ratios are turned into Longs if possible"
  (type 4/2) => Long)

;; From /Clojure Programming/, p427: "double is the only representation that
;; is inherently inexact".

;;;; ___________________________________________________________________________
;;;; ---- `identical?` ----
;;;; The doc string:
;;;;   Tests whether two arguments are the same object.

;; /Clojure Programming/ p433 says:
;;   In general, numbers will never be identical?, even if provided as
;;   literals.

(fact "In general, two numbers created from two same-looking literals are not identical"
  (fact (identical? 2000 2000) => false)
  (fact (identical? 2N 2N)     => false)
  (fact (identical? 2/3 2/3)   => false)
  (fact (identical? 2M 2M)     => false)
  (fact (identical? 2.0M 2.0M) => false)
  (fact (identical? 2.0 2.0)   => false))

(fact "2 is identical to 2, which seems to contradict the statement that numbers will never be identical, but remember the 'in general'"
  (identical? 2 2) => true)

(fact "Same-valued fixnums are identical to each other, but same-valued non-fixnums are not identical to each other"
  ;; Explained by /Clojure Programming/ p433 which says:
  ;;   The exception is that the JVM (and therefore Clojure) provides for a
  ;;   limited range of fixnums. Fixnums are a pool of boxed integer values
  ;;   that are always used in preference to allocating a new integer. [...]
  ;;   The Oracle JVM’s fixnum range is ±127.
  ;;     jsk: Actually -128 to +127
  (fact (identical? -129 -129) => false)
  (fact (identical? -128 -128) => true)
  (fact (identical?  127  127) => true)
  (fact (identical?  128  128) => false))

(fact "But, of course, a number object is identical to itself"
  (let [x 2N] (identical? x x)) => true)

(fact "And, of course, numbers with different representations are not identical"
  (fact (identical? 2 2N)   => false)
  (fact (identical? 2 2M)   => false)
  (fact (identical? 2 2.0M) => false)
  (fact (identical? 2 2.0)  => false))

;;;; ___________________________________________________________________________
;;;; ---- `=` ----
;;;; The doc string:
;;;;   Equality. Returns true if x equals y, false if not. Same as Java
;;;;   x.equals(y) except it also works for nil, and compares numbers and
;;;;   collections in a type-independent manner. Clojure's immutable data
;;;;   structures define equals() (and thus =) as a value, not an identity,
;;;;   comparison.

;; I think there's a problem with the doc string:
;; - What does it mean by "in a type-independent manner"?
;;   - Is this defined in any authoritative place?
;;   - The doc string for `==` uses the phrase "type-independent" with a
;;     different (and, to me, intuitive) meaning.
;; - I would expect e.g. (= 2 2M) => true, but that's not so.
;;   - I'm not the only one:
;;     - See http://dev.clojure.org/jira/browse/CLJ-1333.

;; Jeez, Clojure is poorly specified in places.

;; /Clojure Programming/ p433-444 was helpful.

;; We need the notion of categories of numbers. (Is this defined in any
;; authoritative place?)
;; - We have:
;;   - integers (e.g. 2, 2N)
;;   - ratios (e.g. 2/3)
;;   - arbitrary-precision decimals (e.g. 2M, 2.0M)
;;   - limited-precision decimals (e.g. 2.0, (Float. 2.0))

;;;; ---------------------------------------------------------------------------
;;;; ---- Things that are fine ----

(fact "All types of integer are usefully comparable using `=`"
  ;; From /Clojure Programming/ with adjustments
  (= (Byte. (byte 2))
     (Short. (short 2))
     (Integer. (int 2))
     2
     2N)
  => true)

(fact "Ratios are usefully comparable using `=`"
  (= 2/3 2/3)
  => true)

(fact "Arbitrary-precision decimals are usefully comparable using `=`"
  (= 1.25M
     1.25M)
  => true)

(fact "Limited-precision decimals of different widths are usefully comparable using `=`"
  ;; From /Clojure Programming/
  (= 1.25 ; a Double
     (Float. 1.25))
  => true)

;;;; ---------------------------------------------------------------------------
;;;; ---- The thing that is, in my opinion, contrary to the doc string ----

(fact "`=` returns false for comparisons of equivalent numbers of different categories"
  ;; From /Clojure Programming/ with some changes and additions
  (fact (= 2 2.0)    => false)
  (fact (= 2 2M)     => false)
  (fact (= 2N 2M)    => false)
  (fact (= 1.25 5/4) => false))

;; From /Clojure Programming/:
;;   Clojure’s `=` could obviate these type differences (as Ruby and Python
;;   do), but doing so would impose some runtime cost that would be
;;   unappreciated by those who need to maximize the performance of programs
;;   that work with homogeneous numeric data.

;;;; ---------------------------------------------------------------------------
;;;; ---- My playing ----

;; Shows that "same category" is A Thing, as /Clojure Programming/ says. Shows
;; that the doc string's "type-independent manner" is wrong (according to what
;; I think that should mean).

;; Summary, showing the equivalence classes apart from Ratios:
;;;
;;   Key to the table entries:
;;;
;;         =   means   (= x y) is true
;;         .   means   (= x y) is false
;;             where x is the row value and y is the column value
;;;
;;       F2.0  means   (Float. 2.0)
;;;
;;
;;              --------------------------------------
;;        =     |   2  2N   |  2M 2.0M  |  2.0  F2.0 |
;;     -----------------------------------------------
;;     |        |           |           |            |
;;     |  2     |   =   =   |   .   .   |   .   .    |
;;     |        |           |           |            |
;;     |  2N    |   =   =   |   .   .   |   .   .    |
;;     |        |           |           |            |
;;     -----------------------------------------------
;;     |        |           |           |            |
;;     |  2M    |   .   .   |   =   =   |   .   .    |
;;     |        |           |           |            |
;;     |  2.0M  |   .   .   |   =   =   |   .   .    |
;;     |        |           |           |            |
;;     -----------------------------------------------
;;     |        |           |           |            |
;;     |  2.0   |   .   .   |   .   .   |   =   =    |
;;     |        |           |           |            |
;;     |  F2.0  |   .   .   |   .   .   |   =   =    |
;;     |        |           |           |            |
;;     -----------------------------------------------

(fact "Two numbers of the same type and with equivalent value are equal using `=`"
  (fact (= 2 2)                       => true)
  (fact (= 2N 2N)                     => true)
  (fact (= 2/3 2/3)                   => true)
  (fact (= 2M 2M)                     => true)
  (fact (= 2.0M 2.0M)                 => true)
  (fact (= 2.0 2.0)                   => true)
  (fact (= (Float. 2.0) (Float. 2.0)) => true))

(fact "Two numbers of the same category and with equivalent value are equal using `=`"
  (fact (= 2   2N)           => true)
  (fact (= 2M  2.0M)         => true)
  (fact (= 2.0 (Float. 2.0)) => true))

(fact "Two numbers of different categories are not equal using `=`"
  (fact (= 2    2M)            => false)
  (fact (= 2    2.0M)          => false)
  (fact (= 2    2.0)           => false)
  (fact (= 2    (Float. 2.0))  => false)
  ;;
  (fact (= 2N   2M)            => false)
  (fact (= 2N   2.0M)          => false)
  (fact (= 2N   2.0)           => false)
  (fact (= 2N   (Float. 2.0))  => false)
  ;;
  (fact (= 2M   2.0)           => false)
  (fact (= 2M   (Float. 2.0))  => false)
  ;;
  (fact (= 2.0M 2.0)           => false)
  (fact (= 2.0M (Float. 2.0))  => false))

;;;; ---------------------------------------------------------------------------

(fact "Collections use `=` to determine equality"
  (into #{} [(Byte. (byte 2))
             (Short. (short 2))
             (Integer. (int 2))
             2
             2N
             2M
             2.0M
             2.0
             (Float. 2.0)])
  => #{2 2.0M 2.0})

;;;; ___________________________________________________________________________
;;;; ---- `==` ----
;;;; The doc string:
;;;;   Returns non-nil if nums all have the equivalent value (type-independent),
;;;;   otherwise false.

;; The doc string uses the phrase "type-independent" in a way that is (to me)
;; intuitive, but which has a different meaning to that in the doc string for
;; `=`.

;; From /Clojure Programming/:
;;   Clojure opts to provide a third notion of equality, specifically to
;;   address the need for type-insensitive equivalence tests.

(fact "Numbers with an equivalent value are equal using `==`"
  (== (Byte. (byte 2))
      (Short. (short 2))
      (Integer. (int 2))
      2
      2N
      2M
      2.0M
      2.0
      (Float. 2.0))
  => true)

;;;; ___________________________________________________________________________
;;;; ---- Going from Longs to BigInts and vice versa, or not ----

(def max-long-plus-1 9223372036854775808N)

(fact "About the 'ordinary' arithmetic operators"
  ;;
  (fact "Throw exceptions on overflow"
    (inc Long/MAX_VALUE)
    => (throws ArithmeticException "integer overflow"))
  ;;
  (fact "We can avoid overflow exceptions by coercing to BigInt first"
    (inc (bigint Long/MAX_VALUE))
    => max-long-plus-1)
  ;;
  (fact "Do not demote from BigInt"
    (type (- max-long-plus-1 Long/MAX_VALUE))
    => clojure.lang.BigInt))

(fact "About the xxxx' operators"
  ;;
  (fact "Auto-promote"
    (inc' Long/MAX_VALUE)
    => max-long-plus-1)
  ;;
  (fact "Do not promote if unnecessary"
    (type (inc' 1))
    => Long)
  ;;
  (fact "Do not demote"
    (type (dec' (inc' Long/MAX_VALUE)))
    => clojure.lang.BigInt))

(def boxed-max-long Long/MAX_VALUE)

(fact "About the unchecked-xxxx operators"
  ;;
  (fact "Don't check for overflow"
    (unchecked-inc Long/MAX_VALUE)
    => Long/MIN_VALUE)
  ;;
  (fact "Only do what you expect on longs, not Longs"
    ;; The doc strings for unchecked operations only define what happens
    ;; for (unboxed) longs, not for (boxed) Longs.
    ;; - See https://groups.google.com/d/msg/clojure/1tefVmYKmpc/2hKlXU-c13sJ
    (fact "With a boxed value it seems weird"
      (unchecked-inc boxed-max-long)
      => (throws ArithmeticException "integer overflow"))
    (fact "But with an unboxed value it's as you'd expect"
      (let [unboxed-max-long Long/MAX_VALUE]
        (unchecked-inc unboxed-max-long))
      => Long/MIN_VALUE)))

;;;; ___________________________________________________________________________
;;;; ---- Some things about BigInts and Ratios ----

(fact "About the ratio of a BigInt and a Long-or-a-BigInt"
  (let [an-even-big-int (+' Long/MAX_VALUE 1)
        an-odd-big-int  (+' Long/MAX_VALUE 2)]
    (assert (even? an-even-big-int))
    (assert (odd?  an-odd-big-int))
    (assert (= (type an-even-big-int) clojure.lang.BigInt))
    (assert (= (type an-odd-big-int)  clojure.lang.BigInt))
    (fact "If the ratio is an integer it is a BigInt"
      (type (/ an-even-big-int 2))  => clojure.lang.BigInt
      (type (/ an-even-big-int 2N)) => clojure.lang.BigInt)
    (fact "If ratio is not an integer it is a Ratio"
      (type (/ an-odd-big-int 2))   => clojure.lang.Ratio
      (type (/ an-odd-big-int 2N))  => clojure.lang.Ratio)))

Add something explicit about unboxed values.


(ns eulalie.support
  (:require [plumbing.map]
            [eulalie.core :as eulalie]
            [glossop.core]))

#? (:clj
    (defmacro defissuer [service target-name args req-fn resp-fn & [doc]]
      (let [fname!  (-> target-name name (str "!") symbol)
            fname!! (-> target-name name (str "!!") symbol)
            args'   (into '[creds] (conj args '& '[extra]))
            body  `(eulalie/issue-request!
                    ~service ~(keyword target-name) ~'creds
                    (merge {:service ~service
                            :target ~(keyword target-name)
                            :creds ~'creds}
                           (plumbing.map/keyword-map ~@args)
                           ~'extra)
                    ~req-fn ~resp-fn)
            md     (cond-> (meta target-name)
                     doc (assoc :doc doc))]
        `(do
           (defn ~(with-meta fname!  md) ~args' ~body)
           ~(when-not (:ns &env)
              `(defn ~(with-meta fname!! md) ~args' (glossop.core/<?! ~body)))))))

(ns eulalie.support
  (:require [eulalie.core :as eulalie]
            [plumbing.map]
            [eulalie.core :as eulalie]
            #? (:clj
                [glossop.core]
                :cljs
                [cljs.core.async]))
  #? (:cljs (:require-macros [glossop.macros :refer [<? go-catching]])))

(defmulti translate-error-type
  (fn [service error-type]
    (keyword "eulalie.service" (name service))))
(defmethod translate-error-type :default [_ error-type] error-type)

(defn error->throwable [service {:keys [type message] :as error}]
  (let [type (translate-error-type service error)]
    (ex-info (name type) (assoc error :type type))))

(defn issue-request! [{:keys [body target service] :as req} req-fn resp-fn]
  (go-catching
    (let [{:keys [error body]}
          (<? (eulalie/issue-request!
               (assoc req :body (req-fn target body))))]
      (if error
        (error->throwable service error)
        (resp-fn target body)))))

#? (:clj
    (defmacro defissuer [service target-name args req-fn resp-fn & [doc]]
      (let [fname!  (-> target-name name (str "!") symbol)
            fname!! (-> target-name name (str "!!") symbol)
            args'   (into '[creds] (conj args '& '[extra]))
            body  `(eulalie.support/issue-request!
                    (merge {:service ~service
                            :target ~(keyword target-name)
                            :creds ~'creds}
                           (plumbing.map/keyword-map ~@args)
                           ~'extra)
                    ~req-fn ~resp-fn)
            md     (cond-> (meta target-name)
                     doc (assoc :doc doc))]
        `(do
           (defn ~(with-meta fname!  md) ~args' ~body)
           ~(when-not (:ns &env)
              `(defn ~(with-meta fname!! md) ~args' (glossop.core/<?! ~body)))))))

Make stuff easier for consumers

Make stuff easier for consumers


(ns mikron.runtime.core-test2
  "Property based testing namespace."
  (:require [clojure.test :as test]
            [clojure.test.check.clojure-test :as tc.test #?@(:cljs [:include-macros true])]
            [clojure.test.check.properties :as tc.prop #?@(:cljs [:include-macros true])]
            [clojure.test.check.generators :as tc.gen #?@(:cljs [:include-macros true])]
            [macrowbar.core :as macrowbar]
            [mikron.runtime.core :as mikron]
            [mikron.runtime.test-generators :as test-generators]
            [mikron.runtime.test-util :as test-util]

            ;; Load these for macrowbar
            [cljs.js]
            [cljs.env]))

;; Property based testing

(def buffer (mikron/allocate-buffer 100000))

(macrowbar/emit :debug-self-hosted
  (tc.test/defspec core-test 100
    (tc.prop/for-all
      [[schema value]
       (tc.gen/bind
         test-generators/schema-generator
         (fn [schema]
           (tc.gen/tuple (tc.gen/return (macrowbar/eval `(mikron/schema
                                                           ~schema
                                                           :processor-types #{:pack :unpack})))
                         (test-generators/value-generator schema))))]
      (test-util/equal? value (mikron/with-buffer buffer
                                (->> value (mikron/pack schema)
                                           (mikron/unpack schema)))))))

(ns mikron.runtime.core-test2
  "Property based testing namespace."
  (:require [clojure.test :as test]
            [clojure.test.check.clojure-test :as tc.test #?@(:cljs [:include-macros true])]
            [clojure.test.check.properties :as tc.prop #?@(:cljs [:include-macros true])]
            [clojure.test.check.generators :as tc.gen #?@(:cljs [:include-macros true])]

            ;; Load these for macrowbar
            [cljs.js]
            [cljs.env]

            [macrowbar.core :as macrowbar]
            [mikron.runtime.core :as mikron]
            [mikron.runtime.test-generators :as test-generators]
            [mikron.runtime.test-util :as test-util]))

;; Property based testing

(def buffer (mikron/allocate-buffer 100000))

(macrowbar/emit :debug-self-hosted
  (tc.test/defspec core-test 100
    (tc.prop/for-all
      [[schema value]
       (tc.gen/bind
         test-generators/schema-generator
         (fn [schema]
           (tc.gen/tuple (tc.gen/return (macrowbar/eval `(mikron/schema
                                                           ~schema
                                                           :processor-types #{:pack :unpack})))
                         (test-generators/value-generator schema))))]
      (test-util/equal? value (mikron/with-buffer buffer
                                (->> value (mikron/pack schema)
                                           (mikron/unpack schema)))))))

Load cljs.js and cljs.env before macrowbar is loaded (also - Trigger travis build)


(ns com.frereth.server.comms.registrar
  (:require [clojure.core.async :as async]
            ;; Q: How do I combine these?
            [com.frereth.common.async-zmq]  ; just for the imports
            [com.frereth.common.communication :as com-comm]
            [com.frereth.common.schema :as com-skm]
            [com.frereth.common.util :as util]

            [com.frereth.server.auth-socket :as auth-socket]
            [com.stuartsierra.component :as component]
            [joda-time :as date]
            [ribol.core :refer (raise)]
            [schema.core :as s]
            [taoensso.timbre :as log])
  (:import [com.frereth.common.async_zmq EventPair]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema

(declare do-registrations)
(s/defrecord Registrar [background-worker :- com-skm/async-channel
                        done :- com-skm/async-channel
                        event-loop :- EventPair]
  ;; Make this the absolute dumbest registration manager I can possibly get away with
  ;; I have unit tests that actually set up an authentication
  ;; protocol, of sorts.
  ;; In authentication.clj, which is named incorrectly.
  ;; TODO: Add them into this mix
  ;; After I get the rope thrown across the gorge.
  component/Lifecycle
  (start
   [this]
   (let [done (async/chan)
         almost-started (assoc this
                               :done done)
         background-worker (do-registrations almost-started)]
     (assoc almost-started
                        :background-worker background-worker)))
  (stop
   [this]
   (when-let [done (:done this)]
     (async/close! done)
     (let [[v c]
           (async/alts!! [(async/timeout 250) background-worker])]
       (when-not v
         (log/warn "Telling the background worker to stop timed out"))))
   (assoc this
          :done nil
          :background-worker nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal

(defn define-world-om
  []
  (let [br {:tag :br, :attrs nil, :content nil}]
    {:type :om
     :version [0 9 0]
     ;; TODO: At the very least, use something like enlive/kioo instead
     ;; Note that this nesting seems pretty awfully incorrect
     :body '(form {:attr {:id "authenticate"}
                   :content ["User name:"
                             (br)
                             (input {:attr {:name "principal-name",
                                            :type "text"}
                                     :content [(br)
                                               "Password:"
                                               (input {:attr {:name "auth-token"
                                                              :type "password"}
                                                       :content [(br)]})
                                               (input {:attr {:name "submit"
                                                              :type "submit"
                                                              :value "Log In"}})]})]})}))

(defn define-world-in-sablono
  []
  {:type :sablono
   :version [0 3 6]
   :body [:div {:id "authenticate"}
          "User name:"
          :br
          :input {:name "principal-name"
                  :type "text"}
          :br
          "Password:"
          :br
          :input {:name "auth-token"
                  :type "password"}
          :br
          :input {:name "submit"
                  :type "submit"
                  :value "Log In"}]})

(defn define-initial-auth-world
  []
  (let [body (define-world-in-sablono)]
    {:data (assoc body
                  :name "Initial Local Login"
                  ;; This basic script was taken from
                  ;; http://swannodette.github.io/2013/11/07/clojurescript-101/
                  ;; Vital assumptions here:
                  ;; 1. Basic clojurescript environment
                  ;; 2. use'ing the core.async ns
                  ;; 3. require'd goog.dom as dom and goog.events as events
                  ;; Or, at least, that we're in an interpreter
                  ;; environment/namespace
                  ;; that acts as if those assumptions are true
                  :script '[(defn listen [element event-type]
                              (let [out (chan)]
                                (events/listen element event-type
                                               (fn [e]
                                                 (put! out e)))
                                out))
                            (let [clicks (listen (dom/getElement "submit") "click")]
                              (go (while true
                                    (let [clicked (<! clicks)]
                                      (raise :start-here)))))]
                  ;; TODO: Definitely use garden to build something here
                  :css [])}))

(s/defn authcz :- auth-socket/router-message
  "This needs to do much, much more.
Check the database for rbac. Set up a real session
(and register that with the database).

Or, at the very least, validate that an
OpenID (et al) token is valid.

c.f. auth-socket's dispatch"
  [msg :- com-comm/router-message]
  (let [pretty-msg (try (util/pretty msg)
                        (catch RuntimeException ex
                          (log/error ex "Trying to pretty-format for logging REQUEST\n"
                                     "N.B. This should absolutely never happen")))
        information-to-share-later {:action-url {:port 7841  ; FIXME: magic number
                                                 ;; TODO: Pull this from a config
                                                 ;; file/env var instead
                                                 :address (util/my-ip)
                                                 :protocol :tcp}
                                    ;; FIXME: This needs to be the public key of the action-url
                                    :public-key (util/random-uuid)

                                    ;; Where to download the actual world data
                                    ;; As opposed to just specifying the :html directly
                                    ;; This seems like the approach that makes much more sense,
                                    ;; especially when we're talking about native renderers
                                    ;; It's tempting to make this a "real" URL instance
                                    ;; But clojure doesn't auto-serialize those over EDN
                                    :world-url "http://localhost:9000/index.html"}]
       (log/debug "Trying to supply the Action channel in response to:\n"
                  pretty-msg))
  (log/warn "Set up a web server and switch back to serving data that way")
  ;; TODO: Set up a web server and go back to just sending the URL
  (assoc msg
         :action-url {:port 7841  ; FIXME: Magic Number
                      ;; TODO: Pull this from a config file/env var instead
                      :address (util/my-ip)
                      :protocol :tcp}
         :expires (date/to-java-date (date/plus (date/date-time) (date/days 1)))
         :session-token (util/random-uuid)
         :world (define-initial-auth-world)))

(comment
  (require '[clojure.xml :as xml])
  ;; Figure out how to go from html string to internal XML format
  (let [form "<form>
User name:

<input type=\"text\" name=\"principal-name\" />

Password:

<input type=\"password\" name=\"auth-token\" />

<input type=\"submit\" value=\"Log In\" />
</form>"
        istream (-> form .getBytes java.io.ByteArrayInputStream.)]
    (xml/parse istream))
  )

(s/defn possibly-authorize!
  "TODO: This desperately needs to happen in a background thread.

Return a channel where the response will be written, add that to
an accumulator in do-registrations.

Of course, that direction gets complicated quickly. KISS for now."
  [->out :- com-skm/async-channel
   msg :- com-comm/router-message]
  (log/debug "Possibly authorizing to: " ->out)
  (try
    (let [response-body (authcz (:contents msg))
          response (assoc msg :contents response-body)
          _ (log/debug "Sending\n" (util/pretty response) "\nin response to AUTH request")
          [sent? c] (async/alts!! [[->out response] (async/timeout 500)])]
      (when-not sent?
        (log/error "possibly-authorize: timed out trying to respond with\n"
                   (util/pretty response))))
    (catch RuntimeException ex
      (log/error ex "At this level, really should have been handled via ribol")
      (throw))))

(s/defn do-registrations :- com-skm/async-channel
  ;; TODO: This really seems like it should be a defnk
  [{:keys [done event-loop ex-chan]} :- Registrar]
  (let [done (promise)
        interface (:interface event-loop)
        ->out (:in-chan interface)
        in<- (:ex-chan event-loop)
        raw-sources [in<-]
        minutes-5 (partial async/timeout (* 5 (util/minute)))]
    (async/go
      (log/debug "Entering do-registrations loop. sources w/out timeout: " raw-sources)
      (loop [[v c] (async/alts! (conj raw-sources (minutes-5)))]
        (if v
          (try
            (possibly-authorize! ->out v)
            ;; Don't want buggy inner handling code to break the external interface
            (catch RuntimeException ex
              (log/error ex "Trying to authorize:\n" v))
            (catch Exception ex
              (log/error ex "Trying to authorize:\n" v)))
          (if (not= c in<-)
            (log/debug "do-registrations: heartbeat")
            (do
              (log/debug "Signalling loop exit")
              (deliver done true))))
        (when-not (realized? done)
          (recur (async/alts! (conj raw-sources (minutes-5))))))
      (log/debug "do-registration: Exiting"))))

(comment
  (let [ch (-> dev/system :auth-loop :ex-chan)]
    (async/alts!! [(async/timeout 750) [ch {:contents {:xz 456}
                                            :id 789}]])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public

(s/defn ctor :- Registrar
  [cfg]
  (map->Registrar cfg))

(ns com.frereth.server.comms.registrar
  (:require [clojure.core.async :as async]
            ;; Q: How do I combine these?
            [com.frereth.common.async-zmq]  ; just for the imports
            [com.frereth.common.communication :as com-comm]
            [com.frereth.common.schema :as com-skm]
            [com.frereth.common.util :as util]

            [com.frereth.server.auth-socket :as auth-socket]
            [com.stuartsierra.component :as component]
            [joda-time :as date]
            [ribol.core :refer (raise)]
            [schema.core :as s]
            [taoensso.timbre :as log])
  (:import [com.frereth.common.async_zmq EventPair]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Schema

(declare do-registrations)
(s/defrecord Registrar [background-worker :- com-skm/async-channel
                        done :- com-skm/async-channel
                        event-loop :- EventPair]
  ;; Make this the absolute dumbest registration manager I can possibly get away with
  ;; I have unit tests that actually set up an authentication
  ;; protocol, of sorts.
  ;; In authentication.clj, which is named incorrectly.
  ;; TODO: Add them into this mix
  ;; After I get the rope thrown across the gorge.
  component/Lifecycle
  (start
   [this]
   (let [done (async/chan)
         almost-started (assoc this
                               :done done)
         background-worker (do-registrations almost-started)]
     (assoc almost-started
                        :background-worker background-worker)))
  (stop
   [this]
   (when-let [done (:done this)]
     (async/close! done)
     (let [[v c]
           (async/alts!! [(async/timeout 250) background-worker])]
       (when-not v
         (log/warn "Telling the background worker to stop timed out"))))
   (assoc this
          :done nil
          :background-worker nil)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Internal

(defn define-world-om
  []
  (let [br {:tag :br, :attrs nil, :content nil}]
    {:type :om
     :version [0 9 0]
     ;; TODO: At the very least, use something like enlive/kioo instead
     ;; Note that this nesting seems pretty awfully incorrect
     :body '(form {:attr {:id "authenticate"}
                   :content ["User name:"
                             (br)
                             (input {:attr {:name "principal-name",
                                            :type "text"}
                                     :content [(br)
                                               "Password:"
                                               (input {:attr {:name "auth-token"
                                                              :type "password"}
                                                       :content [(br)]})
                                               (input {:attr {:name "submit"
                                                              :type "submit"
                                                              :value "Log In"}})]})]})}))

(defn define-world-in-sablono
  []
  {:type :sablono
   :version [0 3 6]
   :body [:div {:id "authenticate"}
          "User name:"
          :br
          :input {:name "principal-name"
                  :type "text"}
          :br
          "Password:"
          :br
          :input {:name "auth-token"
                  :type "password"}
          :br
          :input {:name "submit"
                  :type "submit"
                  :value "Log In"}]})

(defn define-initial-auth-world
  []
  (let [body (define-world-in-sablono)]
    {:data (assoc body
                  :name "Initial Local Login"
                  ;; This basic script was taken from
                  ;; http://swannodette.github.io/2013/11/07/clojurescript-101/
                  ;; Vital assumptions here:
                  ;; 1. Basic clojurescript environment
                  ;; 2. use'ing the core.async ns
                  ;; 3. require'd goog.dom as dom and goog.events as events
                  ;; Or, at least, that we're in an interpreter
                  ;; environment/namespace
                  ;; that acts as if those assumptions are true
                  :script '[(ns empty.world
                                 "Need a naming scheme
Although, honestly, for now, user makes as much sense as any"
                                 (:require-macros [cljs.core.async.macros :as asyncm :refer (go go-loop)])
                                 (:require [cljs.core.async :as async]
                                           [goog.dom :as dom]
                                           [goog.events :as events]))
                            (defn listen [element event-type]
                              (let [out (chan)]
                                (events/listen element event-type
                                               (fn [e]
                                                 (put! out e)))
                                out))
                            (let [clicks (listen (dom/getElement "submit") "click")]
                              (go (while true
                                    (let [clicked (<! clicks)]
                                      (raise :start-here)))))]
                  ;; TODO: Definitely use garden to build something here
                  :css [])}))

(s/defn authcz :- auth-socket/router-message
  "This needs to do much, much more.
Check the database for rbac. Set up a real session
(and register that with the database).

Or, at the very least, validate that an
OpenID (et al) token is valid.

c.f. auth-socket's dispatch"
  [msg :- com-comm/router-message]
  (let [pretty-msg (try (util/pretty msg)
                        (catch RuntimeException ex
                          (log/error ex "Trying to pretty-format for logging REQUEST\n"
                                     "N.B. This should absolutely never happen")))
        information-to-share-later {:action-url {:port 7841  ; FIXME: magic number
                                                 ;; TODO: Pull this from a config
                                                 ;; file/env var instead
                                                 :address (util/my-ip)
                                                 :protocol :tcp}
                                    ;; FIXME: This needs to be the public key of the action-url
                                    :public-key (util/random-uuid)

                                    ;; Where to download the actual world data
                                    ;; As opposed to just specifying the :html directly
                                    ;; This seems like the approach that makes much more sense,
                                    ;; especially when we're talking about native renderers
                                    ;; It's tempting to make this a "real" URL instance
                                    ;; But clojure doesn't auto-serialize those over EDN
                                    :world-url "http://localhost:9000/index.html"}]
       (log/debug "Trying to supply the Action channel in response to:\n"
                  pretty-msg))
  (log/warn "Set up a web server and switch back to serving data that way")
  ;; TODO: Set up a web server and go back to just sending the URL
  (assoc msg
         :action-url {:port 7841  ; FIXME: Magic Number
                      ;; TODO: Pull this from a config file/env var instead
                      :address (util/my-ip)
                      :protocol :tcp}
         :expires (date/to-java-date (date/plus (date/date-time) (date/days 1)))
         :session-token (util/random-uuid)
         :world (define-initial-auth-world)))

(comment
  (require '[clojure.xml :as xml])
  ;; Figure out how to go from html string to internal XML format
  (let [form "<form>
User name:

<input type=\"text\" name=\"principal-name\" />

Password:

<input type=\"password\" name=\"auth-token\" />

<input type=\"submit\" value=\"Log In\" />
</form>"
        istream (-> form .getBytes java.io.ByteArrayInputStream.)]
    (xml/parse istream))
  )

(s/defn possibly-authorize!
  "TODO: This desperately needs to happen in a background thread.

Return a channel where the response will be written, add that to
an accumulator in do-registrations.

Of course, that direction gets complicated quickly. KISS for now."
  [->out :- com-skm/async-channel
   msg :- com-comm/router-message]
  (log/debug "Possibly authorizing to: " ->out)
  (try
    (let [response-body (authcz (:contents msg))
          response (assoc msg :contents response-body)
          _ (log/debug "Sending\n" (util/pretty response) "\nin response to AUTH request")
          [sent? c] (async/alts!! [[->out response] (async/timeout 500)])]
      (when-not sent?
        (log/error "possibly-authorize: timed out trying to respond with\n"
                   (util/pretty response))))
    (catch RuntimeException ex
      (log/error ex "At this level, really should have been handled via ribol")
      (throw))))

(s/defn do-registrations :- com-skm/async-channel
  ;; TODO: This really seems like it should be a defnk
  [{:keys [done event-loop ex-chan]} :- Registrar]
  (let [done (promise)
        interface (:interface event-loop)
        ->out (:in-chan interface)
        in<- (:ex-chan event-loop)
        raw-sources [in<-]
        minutes-5 (partial async/timeout (* 5 (util/minute)))]
    (async/go
      (log/debug "Entering do-registrations loop. sources w/out timeout: " raw-sources)
      (loop [[v c] (async/alts! (conj raw-sources (minutes-5)))]
        (if v
          (try
            (possibly-authorize! ->out v)
            ;; Don't want buggy inner handling code to break the external interface
            (catch RuntimeException ex
              (log/error ex "Trying to authorize:\n" v))
            (catch Exception ex
              (log/error ex "Trying to authorize:\n" v)))
          (if (not= c in<-)
            (log/debug "do-registrations: heartbeat")
            (do
              (log/debug "Signalling loop exit")
              (deliver done true))))
        (when-not (realized? done)
          (recur (async/alts! (conj raw-sources (minutes-5))))))
      (log/debug "do-registration: Exiting"))))

(comment
  (let [ch (-> dev/system :auth-loop :ex-chan)]
    (async/alts!! [(async/timeout 750) [ch {:contents {:xz 456}
                                            :id 789}]])))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Public

(s/defn ctor :- Registrar
  [cfg]
  (map->Registrar cfg))

Move basic empty world ns declaration here

Instead of having the renderer set up the same baseline
environment for every world


(ns com.stuartsierra.lazytest2)

;;; PROTOCOLS

(defprotocol TestInvokable
  (invoke-test [t active]))

(defprotocol Successful
  (success? [r]))

;;; Results

(deftype TestResults [source children]
  Successful (success? [] (every? success? children)))

(deftype TestPassed [source states]
  Successful (success? [] true))

(deftype TestFailed [source states]
  Successful (success? [] false))

(deftype TestThrown [source states throwable]
  Successful (success? [] false))

;;; Contexts

(deftype Context [parents before after])

(defn- open-context
  "Opens context c, and all its parents, unless it is already active."
  [active c]
  (let [active (reduce open-context active (:parents c))
        states (map active (:parents c))]
    (if-let [f (:before c)]
      (assoc active c (or (active c) (apply f states)))
      active)))

(defn- close-context
  "Closes context c and removes it from active."
  [active c]
  (let [states (map active (:parents c))]
    (when-let [f (:after c)]
      (apply f (active c) states))
    (let [active (reduce close-context active (:parents c))]
      (dissoc active c))))

(defmacro defcontext
  "Defines a context.
  decl => docstring? [bindings*] before-body* after-fn?
  after-fn => :after [state] after-body*"
  [name & decl]
  (let [m {:name name, :ns *ns*, :file *file*, :line @Compiler/LINE}
        m (if (string? (first decl)) (assoc m :doc (first decl)) m)
        decl (if (string? (first decl)) (next decl) decl)
        bindings (first decl)
        bodies (next decl)]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (vec (map first pairs))
          contexts (vec (map second pairs))
          before (take-while #(not= :after %) bodies)
          after (next (drop-while #(not= :after %) bodies))
          before-fn `(fn ~locals ~@before)]
      (when after (assert (vector? (first after))))
      (let [after-fn (when after
                       `(fn ~(vec (concat (first after) locals))
                          ~@after))]
        `(def ~name (Context ~contexts ~before-fn ~after-fn '~m nil))))))

(defn- has-after?
  "True if Context c or any of its parents has an :after function."
  [c]
  (or (:after c)
      (some has-after? (:parents c))))

;;; Assertion types

(deftype SimpleAssertion [pred] :as this
  TestInvokable
    (invoke-test [active]
      (try
        (if (pred)
          (TestPassed this nil)
          (TestFailed this nil))
        (catch Throwable t
          (TestThrown this nil t)))))

(deftype ContextualAssertion [contexts pred] :as this
  TestInvokable
    (invoke-test [active]
      (let [merged (reduce open-context active contexts)
            states (map merged contexts)]
        (try
         (if (apply pred states)
           (TestPassed this states)
           (TestFailed this states))
         (catch Throwable t
           (TestThrown this states t))
         (finally
          (reduce close-context merged
                  ;; Only close contexts that weren't active at start:
                  (filter #(not (contains? active %))
                          (reverse contexts))))))))

;;; Container types

(deftype SimpleContainer [children] :as this
  TestInvokable
  (invoke-test [active]
    (try
     (TestResults this (map #(invoke-test % active) children))
     (catch Throwable t
       (TestThrown this active t)))))

(deftype ContextualContainer [contexts children] :as this
  TestInvokable
  (invoke-test [active]
    (let [merged (reduce open-context active contexts)
          states (map merged contexts)]
      (try
       (let [results (map #(invoke-test % active) children)]
         ;; Force non-lazy evaluation when contexts need closing:
         (when (some has-after? contexts) (dorun results))
         (TestResults this results))
       (catch Throwable t
         (TestThrown this states t))
       (finally
        (reduce close-context merged
                ;; Only close contexts that weren't active at start:
                (filter #(not (contains? active %))
                        (reverse contexts))))))))

;;; Public API

(defmacro should
  "A series of assertions.  Each assertion is a simple expression,
  which will be compiled into a function.  A string will be attached
  as :doc metadata on the following assertion."
  [& assertions]
  (loop [r [], as assertions]
    (if (seq as)
      (let [[doc form nxt]
            (if (string? (first as))
              [(first as) (second as) (nnext as)]
              [nil (first as) (next as)])]
        (recur (conj r `(SimpleAssertion
                         (fn [] ~form)
                         {:doc ~doc,
                          :form '~form
                          :file *file*,
                          :line ~(:line (meta form))}
                         nil))
               nxt))
      `(SimpleContainer ~r))))

(defmacro given
  "A series of assertions using values from contexts.
  bindings is a vector of name-value pairs, like let, where each value
  is a context created with defcontext.  A string will be attached
  as :doc metadata on the following assertion."
  [bindings & assertions]
  (assert (vector? bindings))
  (assert (even? (count bindings)))
  (let [pairs (partition 2 bindings)
        locals (vec (map first pairs))
        contexts (vec (map second pairs))]
    (loop [r [], as assertions]
      (if (seq as)
        (let [[doc form nxt]
              (if (string? (first as))
                [(first as) (second as) (nnext as)]
                [nil (first as) (next as)])]
          (recur (conj r `(ContextualAssertion
                           ~contexts
                           (fn ~locals ~form)
                           {:doc ~doc,
                            :locals '~locals
                            :form '~form
                            :file *file*,
                            :line ~(:line (meta form))}
                           nil))
                 nxt))
        `(SimpleContainer ~r)))))

(defn- attributes
  "Reads optional name symbol and doc string from args,
  returns [m a] where m is a map containing keys
  [:name :doc :ns :file :line] and a is remaining arguments."
  [args]
  (let [m {:ns *ns*, :file *file*, :line @Compiler/LINE}
        m    (if (symbol? (first args)) (assoc m :name (first args)))
        args (if (symbol? (first args)) (next args) args)
        m    (if (string? (first args)) (assoc m :doc (first args)))
        args (if (string? (first args)) (next args) args)]
    [m args]))

(defn- options
  "Reads keyword-value pairs from args, returns [m a] where m is a map
  of keyword/value options and a is remaining arguments."
  [args]
  (loop [opts {}, as args]
    (if (and (seq as) (keyword? (first as)))
      (recur (assoc opts (first as) (second as)) (nnext as))
      [opts as])))

(defmacro testing
  "Creates a test container.
  decl   => name? docstring? option* child*

  name  => a symbol, will def a Var if provided.
  child => 'should' or 'given' or nested 'testing'.

  options => keyword/value pairs, recognized keys are:
    :contexts => vector of contexts to run only once for this container.
    :strategy => a test-running strategy."
  [& decl]
  (let [[m decl] (attributes decl)
        [opts decl] (options decl)
        {:keys [contexts strategy]} opts
        children (vec decl)
        sym (gensym "c")]
    `(let [~sym ~(if contexts
                    (do (assert (vector? contexts))
                        `(ContextualContainer ~contexts ~children '~m nil))
                    `(SimpleContainer ~children '~m nil))]
       ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
       ~sym)))

(defmacro dotest
  "Creates an assertion function consisting of arbitrary code.
  Passes if it does not throw an exception.  Use assert for value
  tests.

  decl    => name? docstring? [binding*] body*
  binding => symbol context

  name  => a symbol, will def a Var if provided.
"
  [& decl]
  (let [[m decl] (attributes decl)
        bindings (first decl)
        body (next decl)
        sym (gensym "c")]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (map first pairs)
          contexts (map second pairs)]
      `(let [~sym ~(if (seq contexts)
                     `(ContextualAssertion ~contexts (fn ~locals ~@body :ok)
                                           '~m nil)
                     `(SimpleAssertion (fn [] ~@body :ok) '~m nil))]
         ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
         ~sym))))

(ns com.stuartsierra.lazytest2)

;;; PROTOCOLS

(defprotocol TestInvokable
  (invoke-test [t active]))

(defprotocol Successful
  (success? [r]))

;;; Results

(deftype TestResults [source children]
  Successful (success? [] (every? success? children)))

(deftype TestPassed [source states]
  Successful (success? [] true))

(deftype TestFailed [source states]
  Successful (success? [] false))

(deftype TestThrown [source states throwable]
  Successful (success? [] false))

(defn result-seq
  "Given a single TestResult, returns a depth-first sequence of that
  TestResult and all its children."
  [r]
  (tree-seq :children :children r))

(defn result-meta
  "Given a TestResult, returns the metadata map of its source."
  [r]
  (meta (:source r)))

;;; Contexts

(deftype Context [parents before after])

(defn- open-context
  "Opens context c, and all its parents, unless it is already active."
  [active c]
  (let [active (reduce open-context active (:parents c))
        states (map active (:parents c))]
    (if-let [f (:before c)]
      (assoc active c (or (active c) (apply f states)))
      active)))

(defn- close-context
  "Closes context c and removes it from active."
  [active c]
  (let [states (map active (:parents c))]
    (when-let [f (:after c)]
      (apply f (active c) states))
    (let [active (reduce close-context active (:parents c))]
      (dissoc active c))))

(defmacro defcontext
  "Defines a context.
  decl => docstring? [bindings*] before-body* after-fn?
  after-fn => :after [state] after-body*"
  [name & decl]
  (let [m {:name name, :ns *ns*, :file *file*, :line @Compiler/LINE}
        m (if (string? (first decl)) (assoc m :doc (first decl)) m)
        decl (if (string? (first decl)) (next decl) decl)
        bindings (first decl)
        bodies (next decl)]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (vec (map first pairs))
          contexts (vec (map second pairs))
          before (take-while #(not= :after %) bodies)
          after (next (drop-while #(not= :after %) bodies))
          before-fn `(fn ~locals ~@before)]
      (when after (assert (vector? (first after))))
      (let [after-fn (when after
                       `(fn ~(vec (concat (first after) locals))
                          ~@after))]
        `(def ~name (Context ~contexts ~before-fn ~after-fn '~m nil))))))

(defn- has-after?
  "True if Context c or any of its parents has an :after function."
  [c]
  (or (:after c)
      (some has-after? (:parents c))))

;;; Assertion types

(deftype SimpleAssertion [pred] :as this
  TestInvokable
    (invoke-test [active]
      (try
        (if (pred)
          (TestPassed this nil)
          (TestFailed this nil))
        (catch Throwable t
          (TestThrown this nil t)))))

(deftype ContextualAssertion [contexts pred] :as this
  TestInvokable
    (invoke-test [active]
      (let [merged (reduce open-context active contexts)
            states (map merged contexts)]
        (try
         (if (apply pred states)
           (TestPassed this states)
           (TestFailed this states))
         (catch Throwable t
           (TestThrown this states t))
         (finally
          (reduce close-context merged
                  ;; Only close contexts that weren't active at start:
                  (filter #(not (contains? active %))
                          (reverse contexts))))))))

;;; Container types

(deftype SimpleContainer [children] :as this
  TestInvokable
  (invoke-test [active]
    (try
     (TestResults this (map #(invoke-test % active) children))
     (catch Throwable t
       (TestThrown this active t)))))

(deftype ContextualContainer [contexts children] :as this
  TestInvokable
  (invoke-test [active]
    (let [merged (reduce open-context active contexts)
          states (map merged contexts)]
      (try
       (let [results (map #(invoke-test % active) children)]
         ;; Force non-lazy evaluation when contexts need closing:
         (when (some has-after? contexts) (dorun results))
         (TestResults this results))
       (catch Throwable t
         (TestThrown this states t))
       (finally
        (reduce close-context merged
                ;; Only close contexts that weren't active at start:
                (filter #(not (contains? active %))
                        (reverse contexts))))))))

;;; Public API

(defmacro should
  "A series of assertions.  Each assertion is a simple expression,
  which will be compiled into a function.  A string will be attached
  as :doc metadata on the following assertion."
  [& assertions]
  (loop [r [], as assertions]
    (if (seq as)
      (let [[doc form nxt]
            (if (string? (first as))
              [(first as) (second as) (nnext as)]
              [nil (first as) (next as)])]
        (recur (conj r `(SimpleAssertion
                         (fn [] ~form)
                         {:doc ~doc,
                          :form '~form
                          :file *file*,
                          :line ~(:line (meta form))}
                         nil))
               nxt))
      `(SimpleContainer ~r))))

(defmacro given
  "A series of assertions using values from contexts.
  bindings is a vector of name-value pairs, like let, where each value
  is a context created with defcontext.  A string will be attached
  as :doc metadata on the following assertion."
  [bindings & assertions]
  (assert (vector? bindings))
  (assert (even? (count bindings)))
  (let [pairs (partition 2 bindings)
        locals (vec (map first pairs))
        contexts (vec (map second pairs))]
    (loop [r [], as assertions]
      (if (seq as)
        (let [[doc form nxt]
              (if (string? (first as))
                [(first as) (second as) (nnext as)]
                [nil (first as) (next as)])]
          (recur (conj r `(ContextualAssertion
                           ~contexts
                           (fn ~locals ~form)
                           {:doc ~doc,
                            :locals '~locals
                            :form '~form
                            :file *file*,
                            :line ~(:line (meta form))}
                           nil))
                 nxt))
        `(SimpleContainer ~r)))))

(defn- attributes
  "Reads optional name symbol and doc string from args,
  returns [m a] where m is a map containing keys
  [:name :doc :ns :file :line] and a is remaining arguments."
  [args]
  (let [m {:ns *ns*, :file *file*, :line @Compiler/LINE}
        m    (if (symbol? (first args)) (assoc m :name (first args)))
        args (if (symbol? (first args)) (next args) args)
        m    (if (string? (first args)) (assoc m :doc (first args)))
        args (if (string? (first args)) (next args) args)]
    [m args]))

(defn- options
  "Reads keyword-value pairs from args, returns [m a] where m is a map
  of keyword/value options and a is remaining arguments."
  [args]
  (loop [opts {}, as args]
    (if (and (seq as) (keyword? (first as)))
      (recur (assoc opts (first as) (second as)) (nnext as))
      [opts as])))

(defmacro testing
  "Creates a test container.
  decl   => name? docstring? option* child*

  name  => a symbol, will def a Var if provided.
  child => 'should' or 'given' or nested 'testing'.

  options => keyword/value pairs, recognized keys are:
    :contexts => vector of contexts to run only once for this container.
    :strategy => a test-running strategy."
  [& decl]
  (let [[m decl] (attributes decl)
        [opts decl] (options decl)
        {:keys [contexts strategy]} opts
        children (vec decl)
        sym (gensym "c")]
    `(let [~sym ~(if contexts
                    (do (assert (vector? contexts))
                        `(ContextualContainer ~contexts ~children '~m nil))
                    `(SimpleContainer ~children '~m nil))]
       ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
       ~sym)))

(defmacro dotest
  "Creates an assertion function consisting of arbitrary code.
  Passes if it does not throw an exception.  Use assert for value
  tests.

  decl    => name? docstring? [binding*] body*
  binding => symbol context

  name  => a symbol, will def a Var if provided.
"
  [& decl]
  (let [[m decl] (attributes decl)
        bindings (first decl)
        body (next decl)
        sym (gensym "c")]
    (assert (vector? bindings))
    (assert (even? (count bindings)))
    (let [pairs (partition 2 bindings)
          locals (map first pairs)
          contexts (map second pairs)]
      `(let [~sym ~(if (seq contexts)
                     `(ContextualAssertion ~contexts (fn ~locals ~@body :ok)
                                           '~m nil)
                     `(SimpleAssertion (fn [] ~@body :ok) '~m nil))]
         ~(when (:name m) `(intern *ns* '~(:name m) ~sym))
         ~sym))))

Add some more docs, result-seq, result-meta


(ns reagent-tutorial.core
  (:require [clojure.string :as string]
            [reagent.core :as r]))

(enable-console-print!)

;; The "database" of your client side UI.
(def app-state
  (r/atom
   {:contacts
    [{:first "Ben" :last "Bitdiddle" :email "benb@mit.edu"}
     {:first "Alyssa" :middle-initial "P" :last "Hacker" :email "aphacker@mit.edu"}
     {:first "Eva" :middle "Lu" :last "Ator" :email "eval@mit.edu"}
     {:first "Louis" :last "Reasoner" :email "prolog@mit.edu"}
     {:first "Cy" :middle-initial "D" :last "Effect" :email "bugs@mit.edu"}
     {:first "Lem" :middle-initial "E" :last "Tweakit" :email "morebugs@mit.edu"}]}))

(defn update-contacts! [f & args]
  (apply swap! app-state update-in [:contacts] f args))

(defn add-contact! [c]
  (update-contacts! conj c))

(defn remove-contact! [c]
  (update-contacts! (fn [cs]
                      (vec (remove #(= % c) cs)))
                    c))

;; The next three fuctions are copy/pasted verbatim from the Om tutorial
(defn middle-name [{:keys [middle middle-initial]}]
  (cond
   middle (str " " middle)
   middle-initial (str " " middle-initial ".")))

(defn display-name [{:keys [first last] :as contact}]
  (str last ", " first (middle-name contact)))

(defn parse-contact [contact-str]
  (let [[first middle last :as parts] (string/split contact-str #"\s+")
        [first last middle] (if (nil? last) [first middle] [first last middle])
        middle (when middle (string/replace middle "." ""))
        c (if middle (count middle) 0)]
    (when (>= (reduce + (map #(if % 1 0) parts)) 2)
      (cond-> {:first first :last last}
        (== c 1) (assoc :middle-initial middle)
        (>= c 2) (assoc :middle middle)))))

;; UI components
(defn contact []
  (fn [c]
    [:li
     [:span (display-name c)]
     [:button {:on-click #(remove-contact! c)}
      "Delete"]]))

(defn new-contact []
  (let [val (r/atom "")]
    (fn []
      [:div
       [:input {:type "text"
                :placeholder "Contact Name"
                :value @val
                :on-change #(reset! val (-> % .-target .-value))}]
       [:button {:on-click #(when-let [c (parse-contact @val)]
                              (add-contact! c)
                              (reset! val ""))}
        "Add"]])))

(defn contacts []
  [:div
   [:h1 "Contact list"]
   [:ul
    (for [c (:contacts @app-state)]
      [contact c])]
   [new-contact]])

;; Render the root component
(defn start []
  (r/render-component
   [contacts]
   (.getElementById js/document "root")))

(ns reagent-tutorial.core
  (:require [clojure.string :as string]
            [reagent.core :as r]))

(enable-console-print!)

;; The "database" of your client side UI.
(def app-state
  (r/atom
   {:contacts
    [{:first "Ben" :last "Bitdiddle" :email "benb@mit.edu"}
     {:first "Alyssa" :middle-initial "P" :last "Hacker" :email "aphacker@mit.edu"}
     {:first "Eva" :middle "Lu" :last "Ator" :email "eval@mit.edu"}
     {:first "Louis" :last "Reasoner" :email "prolog@mit.edu"}
     {:first "Cy" :middle-initial "D" :last "Effect" :email "bugs@mit.edu"}
     {:first "Lem" :middle-initial "E" :last "Tweakit" :email "morebugs@mit.edu"}]}))

(defn update-contacts! [f & args]
  (apply swap! app-state update-in [:contacts] f args))

(defn add-contact! [c]
  (update-contacts! conj c))

(defn remove-contact! [c]
  (update-contacts! (fn [cs]
                      (vec (remove #(= % c) cs)))
                    c))

;; The next three fuctions are copy/pasted verbatim from the Om tutorial
(defn middle-name [{:keys [middle middle-initial]}]
  (cond
   middle (str " " middle)
   middle-initial (str " " middle-initial ".")))

(defn display-name [{:keys [first last] :as contact}]
  (str last ", " first (middle-name contact)))

(defn parse-contact [contact-str]
  (let [[first middle last :as parts] (string/split contact-str #"\s+")
        [first last middle] (if (nil? last) [first middle] [first last middle])
        middle (when middle (string/replace middle "." ""))
        c (if middle (count middle) 0)]
    (when (>= (reduce + (map #(if % 1 0) parts)) 2)
      (cond-> {:first first :last last}
        (== c 1) (assoc :middle-initial middle)
        (>= c 2) (assoc :middle middle)))))

;; UI components
(defn contact [c]
  [:li
   [:span (display-name c)]
   [:button {:on-click #(remove-contact! c)}
    "Delete"]])

(defn new-contact []
  (let [val (r/atom "")]
    (fn []
      [:div
       [:input {:type "text"
                :placeholder "Contact Name"
                :value @val
                :on-change #(reset! val (-> % .-target .-value))}]
       [:button {:on-click #(when-let [c (parse-contact @val)]
                              (add-contact! c)
                              (reset! val ""))}
        "Add"]])))

(defn contacts []
  [:div
   [:h1 "Contact list"]
   [:ul
    (for [c (:contacts @app-state)]
      [contact c])]
   [new-contact]])

;; Render the root component
(defn start []
  (r/render-component
   [contacts]
   (.getElementById js/document "root")))

simplify contact component

simplify contact component