git » blacktide.git » master » tree

[master] / test / com / tailrecursion / blacktide / invocation_test.clj 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
(ns com.tailrecursion.blacktide.invocation-test
  "Direct protocol calls select interface dispatch before falling back to the
  method Var. Compare values, failures and evaluation traces with Clojure."
  (:require [clojure.test :refer [deftest is]]
            [clojure.core.protocols :as p]
            [com.tailrecursion.blacktide.backend-fixture :as backend]
            [com.tailrecursion.blacktide.jvm-fixture]))

(deftype DirectReduction [events]
  p/CollReduce
  (coll-reduce [_ f] (swap! events conj :interface) (f :direct))
  (coll-reduce [_ f init] (swap! events conj :interface) (f init :direct)))

(defn observe [form mode direct? target-kind replacement]
  (binding [*compiler-options* {:direct-linking direct?}]
    (let [events (atom []) f ((backend/compile-program form mode) nil)
          target (case target-kind :direct (DirectReduction. events) :nil nil :vector [1 2])
          replacement (case replacement :function (fn [& xs] (swap! events conj :fallback) (vec (rest xs)))
                                       :nil nil :invalid 42)]
      (with-redefs [p/coll-reduce replacement]
        (let [out (try {:value (f target events)} (catch Throwable e {:throw (class e)}))]
          (assoc out :trace @events))))))

(defn record-result [events tag & _] (swap! events conj tag) tag)

(defn wrapped [body location]
  (case location
    :region (list 'fn '[target events] (list 'loophole [] body))
    :ordinary (list 'fn '[target events] body)))

(deftest direct-protocol-and-first-class-calls-stay-distinct
  (doseq [body '[(clojure.core.protocols/coll-reduce target vector)
                (clojure.core.protocols/coll-reduce target vector 7)
                ((do clojure.core.protocols/coll-reduce) target vector 7)
                (let [f clojure.core.protocols/coll-reduce] (f target vector 7))]
          target [:direct :nil :vector] direct? [false true]
          mode [:default :dispatcher]]
    (is (= (observe (wrapped body :ordinary) :default direct? target :function)
           (observe (wrapped body :region) mode direct? target :function))
        (pr-str [body target direct? mode]))))

(deftest fallback-root-is-read-after-the-target-before-later-arguments
  (let [body '(clojure.core.protocols/coll-reduce
                (do (swap! events conj :target)
                    (alter-var-root #'clojure.core.protocols/coll-reduce
                                    (constantly (partial com.tailrecursion.blacktide.invocation-test/record-result events :early))) target)
                (do (swap! events conj :argument)
                    (alter-var-root #'clojure.core.protocols/coll-reduce
                                    (constantly (partial com.tailrecursion.blacktide.invocation-test/record-result events :late))) vector)
                (do (swap! events conj :initial) 7))]
    (doseq [target [:direct :nil :vector] mode [:default :dispatcher]]
      (is (= (observe (wrapped body :ordinary) :default false target :function)
             (observe (wrapped body :region) mode false target :function))
          (pr-str [target mode])))))

(deftest invalid-fallback-roots-fail-after-arguments
  (doseq [body '[(clojure.core.protocols/coll-reduce
                  (do (swap! events conj :target) target)
                  (do (swap! events conj :argument) vector)
                  (do (swap! events conj :initial) 7))
                (clojure.core.protocols/coll-reduce target vector
                  (do (swap! events conj :throw) (throw (ex-info "argument" {}))))]
          target [:direct :nil] replacement [:nil :invalid]
          mode [:default :dispatcher]]
    (is (= (observe (wrapped body :ordinary) :default false target replacement)
           (observe (wrapped body :region) mode false target replacement))
        (pr-str [body target replacement mode]))))

(deftest protocol-operands-may-change-region-state
  (let [body '(clojure.core.protocols/coll-reduce
                (do (swap! events conj :target) target)
                (do (swap! events conj :argument) vector)
                (do (swap! events conj :initial) 7))
        source '(fn [target events]
                  (loophole [x nil]
                    (clojure.core.protocols/coll-reduce
                      (do (swap! events conj :target) (setq x target))
                      (do (swap! events conj :argument) (setq x vector))
                      (do (swap! events conj :initial) (setq x 7)))))]
    (doseq [target [:direct :nil :vector] mode [:default :dispatcher]]
      (is (= (observe (wrapped body :ordinary) :default false target :function)
             (observe source mode false target :function))))))

(defmacro remove-protocol [value]
  (alter-meta! #'p/coll-reduce dissoc :protocol)
  value)

(deftest protocol-facts-are-captured-after-arguments-before-following-forms
  (let [metadata (meta #'p/coll-reduce)
        observe (fn [body mode location]
                  (try (reset-meta! #'p/coll-reduce metadata)
                       (observe (wrapped body location) mode false :direct :function)
                       (finally (reset-meta! #'p/coll-reduce metadata))))]
    (doseq [body '[(do (clojure.core.protocols/coll-reduce target vector 7)
                      (com.tailrecursion.blacktide.invocation-test/remove-protocol :done))
                  (clojure.core.protocols/coll-reduce
                    (com.tailrecursion.blacktide.invocation-test/remove-protocol target) vector 7)]
            mode [:default :dispatcher]]
      (is (= (observe body :default :ordinary) (observe body mode :region))
          (pr-str [body mode])))))

(deftest invalid-direct-protocol-arity-is-rejected-at-compilation
  (doseq [body '[(clojure.core.protocols/coll-reduce)
                (clojure.core.protocols/coll-reduce target)
                (clojure.core.protocols/coll-reduce target vector 7 8)]
          location [:ordinary :region] mode [:default :dispatcher]]
    (is (thrown? clojure.lang.Compiler$CompilerException
                 (backend/compile-program (wrapped body location) mode))
        (pr-str [body location mode]))))

;; Existing Java interfaces can also be protocol dispatch targets. They expose
;; conversions that the Object-only interfaces generated by defprotocol cannot.
(def java-list {:on 'java.util.List :method-map {:list-set :set}})
(defn list-set [& _] :fallback)
(alter-meta! #'list-set assoc :protocol #'java-list)
(deftest interface-conversions-are-conditional-and-ordered
  (let [observe (fn [body mode location direct?]
                  (let [events (atom []) f ((backend/compile-program (wrapped body location) mode) nil)
                        target (when direct? (java.util.ArrayList. [1 2]))]
                    [(try [:value (f target events)] (catch Throwable e [:throw (class e)]))
                     (when target (vec target)) @events]))]
    (doseq [index [0 2147483648 nil] direct? [false true]
            mode [:default :dispatcher]
            :let [body (list 'com.tailrecursion.blacktide.invocation-test/list-set 'target
                             (list 'do '(swap! events conj :index) index)
                             '(do (swap! events conj :value) :new))]]
      (is (= (observe body :default :ordinary direct?) (observe body mode :region direct?))
          (pr-str [index direct? mode])))))

(deftest interface-functional-arguments
  (let [body '(com.tailrecursion.blacktide.jvm-fixture/map-compute target :key
                (do (swap! events conj :argument) vector))
        observe (fn [mode location direct?]
                  (let [events (atom []) f ((backend/compile-program (wrapped body location) mode) nil)
                        target (when direct? (java.util.HashMap. {:key :old}))]
                    [(f target events) (when target (into {} target)) @events]))]
    (doseq [direct? [false true] mode [:default :dispatcher]]
      (is (= (observe :default :ordinary direct?) (observe mode :region direct?))
          (pr-str [direct? mode])))))