git » blacktide.git » master » tree

[master] / test / com / tailrecursion / blacktide / lookup_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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
(ns com.tailrecursion.blacktide.lookup-test
  "Keyword syntax retains lookup dispatch, values and source effects.
  Cache installation and unsuccessful probes are not observable contracts."
  (:require [clojure.test :refer [deftest is]]
            [com.tailrecursion.blacktide.backend-fixture :as backend]
            [com.tailrecursion.blacktide.compiler.passes.structure :as structure]))

(deftype ObservedLookup [events entries]
  clojure.lang.ILookup
  (valAt [_ key] (swap! events conj [:val key]) (get entries key))
  (valAt [_ key default] (swap! events conj [:default key]) (get entries key default))
  clojure.lang.IKeywordLookup
  (getLookupThunk [_ key]
    (reify clojure.lang.ILookupThunk
      (get [thunk target]
        (if (instance? ObservedLookup target)
          (do (swap! (.-events ^ObservedLookup target) conj [:get key])
              (get (.-entries ^ObservedLookup target) key))
          thunk)))))

(deftype UncachedLookup [events entries]
  clojure.lang.ILookup
  (valAt [_ key] (swap! events conj [:val key]) (get entries key))
  (valAt [_ key default] (swap! events conj [:default key]) (get entries key default))
  clojure.lang.IKeywordLookup
  (getLookupThunk [_ _] nil))

(def ^:const constant-key :k)
(defmacro lookup [target] `(:k ~target))
(defmacro lookup-key [] :k)

(defn trace [function]
  (let [events (atom []) a (ObservedLookup. events {:k 7}) b (ObservedLookup. events {:k nil})
        c (UncachedLookup. events {:k 9})
        targets [a a b c c {:k 11} nil a {} (java.util.HashMap. {:k 13})]]
    [(mapv #(function % events) targets) @events]))

(deftest keyword-call-syntax
  (doseq [body '[(:k (do (swap! events conj :target) target))
                (:missing target)
                (:k (do (swap! events conj :target) target) (do (swap! events conj :default) 17))
                ((quote :k) target)
                (let [key :k] (key target))
                ((do :k) target)
                ((if true :k :other) target)
                (com.tailrecursion.blacktide.lookup-test/constant-key target)
                ((com.tailrecursion.blacktide.lookup-test/lookup-key) target)
                (com.tailrecursion.blacktide.lookup-test/lookup target)]
          wrap [identity #(list 'loop [] %)]
          :let [form (list 'fn '[target events] (wrap body))
                reference ((backend/compile-program form :default) nil)]
          mode [:default :dispatcher]
          :let [compiled ((backend/compile-program (list 'fn '[target events] (list 'loophole [] (wrap body))) mode) nil)]]
    (is (= (trace reference) (trace compiled)) (pr-str [body mode (wrap body)]))))

(deftest keyword-lookups-across-backward-jumps
  (let [reference '(fn [target events]
                     (loop [i 0 out []]
                       (if (< i 3) (recur (inc i) (conj out (:k target))) out)))
        source '(fn [target events]
                  (loophole [i 0 out []]
                    (label again)
                    (setq out (conj out (:k target)) i (inc i))
                    (when (< i 3) (goto again)) out))]
    (doseq [mode [:default :dispatcher]]
      (is (= (trace ((backend/compile-program reference :default) nil))
             (trace ((backend/compile-program source mode) nil))) (str mode)))))

(deftest argument-and-lookup-failures
  (doseq [mode [:default :dispatcher] fail-argument? [false true]]
    (let [events (atom [])
          target (reify clojure.lang.IKeywordLookup
                   (getLookupThunk [_ _]
                     (reify clojure.lang.ILookupThunk
                       (get [_ _] (swap! events conj :lookup) (throw (ex-info "lookup" {:phase :lookup}))))))
          f ((backend/compile-program
               '(fn [target fail?]
                  (loophole [saved nil]
                    (:k (do (swap! events conj :argument)
                            (when fail? (throw (ex-info "argument" {:phase :argument})))
                            (setq saved target))))) mode) events)]
      (is (= {:phase (if fail-argument? :argument :lookup)}
             (try (f target fail-argument?) (catch clojure.lang.ExceptionInfo e (ex-data e)))))
      (is (= (if fail-argument? [:argument] [:argument :lookup]) @events)))))

(deftest assigned-keyword-targets
  (doseq [operator '[:k :missing (quote :k) (do :k)
                    (com.tailrecursion.blacktide.lookup-test/lookup-key)
                    com.tailrecursion.blacktide.lookup-test/constant-key
                    com.tailrecursion.blacktide.lookup-test/lookup]
          mode [:default :dispatcher]
          :let [target '(do (swap! events conj :target) target)
                assigned '(do (swap! events conj :target) (setq saved target))
                reference (list 'fn '[target events] (list operator target))
                source (list 'fn '[target events] (list 'loophole '[saved nil] (list operator assigned)))]]
    (is (= (trace ((backend/compile-program reference :default) nil))
           (trace ((backend/compile-program source mode) nil))) (pr-str [operator mode])))
  (doseq [mode [:default :dispatcher]
          :let [reference '(fn [target events] [(:k target) true])
                source '(fn [target events]
                          (loophole [saved nil]
                            (let [result (:k (case (count (swap! events identity))
                                              0 (setq saved target)
                                              (do (psetq saved target) saved)))]
                              [result (identical? saved target)])))]]
    (is (= (trace ((backend/compile-program reference :default) nil))
           (trace ((backend/compile-program source mode) nil))) (str mode))))

(deftest reentrant-argument-evaluation
  (let [reference '(fn read-key [target events]
                     (:k (do (swap! events conj :target)
                             (if (vector? target)
                               (do (read-key (first target) events) (second target)) target))))
        source '(fn read-key [target events]
                  (loophole [saved nil]
                    (:k (do (swap! events conj :target)
                            (setq saved (if (vector? target)
                                          (do (read-key (first target) events) (second target)) target))))))
        run (fn [form mode]
              (let [f ((backend/compile-program form mode) nil)
                    events (atom []) a (ObservedLookup. events {:k 7}) b (UncachedLookup. events {:k 9})]
                [(f [a b] events) (f [b a] events) (f a events) @events]))]
    (doseq [mode [:default :dispatcher]
            form [source (list 'fn 'read-key '[target events] (list 'loophole [] (last reference)))]]
      (is (= (run reference :default) (run form mode)) (str mode)))))

(deftest skipped-lookup-and-reentry
  (let [reference '(fn [target events]
                     (loop [i 0 out []]
                       (if (< i 3)
                         (if (= i 1) (recur (inc i) out)
                           (recur (inc i) (conj out (:k (do (swap! events conj :target) target))))) out)))
        source '(fn [target events]
                  (loophole [i 0 out [] saved nil]
                    (label again)
                    (when (= i 1) (setq i (inc i)) (goto again))
                    (setq out (conj out (:k (do (swap! events conj :target) (setq saved target)))))
                    (setq i (inc i)) (when (< i 3) (goto again)) out))]
    (doseq [mode [:default :dispatcher]]
      (is (= (trace ((backend/compile-program reference :default) nil))
             (trace ((backend/compile-program source mode) nil))) (str mode)))))

(deftest assigned-lookup-after-multiple-scope-entries
  (let [reference '(fn [flag target events] [(if flag 3 7) (:k target)])
        source '(fn [flag target events]
                  (loophole [a 0 b 0 saved nil]
                    (if flag (setq a 1 b 2) (setq a 3 b 4))
                    (label again)
                    (when (neg? a) (goto again))
                    [(+ a b) (:k (setq saved target))]))
        run (fn [form mode]
              (let [f ((backend/compile-program form mode) nil)
                    events (atom []) target (ObservedLookup. events {:k 42})]
                [(mapv #(f % target events) [true false false true]) @events]))]
    (is (= :structured (:op (backend/capture #'structure/recover source))))
    (doseq [mode [:default :dispatcher]]
      (is (= (run reference :default) (run source mode)) (str mode)))))