diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml
index a3bbc13db..310f4643b 100644
--- a/.github/workflows/main.yml
+++ b/.github/workflows/main.yml
@@ -69,6 +69,9 @@ jobs:
- { os: macos-latest, shell: bash }
- { os: ubuntu-latest, shell: bash }
- { os: windows-latest, shell: powershell }
+ clojure:
+ - 1.10.3
+ - 1.12.0
defaults:
run:
@@ -98,7 +101,10 @@ jobs:
key: ${{ runner.os }}-maven-test-${{ hashFiles('deps.edn') }}
- name: ๐งช Run tests
- run: bb test:clj :kaocha/reporter '[kaocha.report/documentation]'
+ shell: bash
+ run: |
+ bb test:clj :kaocha/reporter '[kaocha.report/documentation]' \
+ :clojure '"${{ matrix.clojure }}"'
static-build:
runs-on: ubuntu-latest
diff --git a/bb.edn b/bb.edn
index 15c19a7ab..2fcb7d934 100644
--- a/bb.edn
+++ b/bb.edn
@@ -50,7 +50,11 @@
:task (run '-check {:parallel true})}
test:clj {:doc "Run clojure tests"
- :task (apply clojure "-X:test" *command-line-args*)}
+ :task
+ (let [{clojure-version :clojure} (cli/parse-opts *command-line-args*)]
+ (apply clojure (cond-> "-X:test"
+ clojure (str ":" clojure-version))
+ *command-line-args*))}
playwright:version {:doc "Print used playwright version from ui_tests/yarn.json"
:task (print (->> (babashka.process/shell {:out :string} "grep -E 'playwright-core \"(.*)\"' ui_tests/yarn.lock")
diff --git a/build.clj b/build.clj
index f64c660b0..4badd2827 100644
--- a/build.clj
+++ b/build.clj
@@ -1,6 +1,5 @@
(ns build
(:require
- [babashka.process :as process]
[clojure.string :as str]
[clojure.tools.build.api :as b]
[nextjournal.clerk.config :as config]
@@ -38,7 +37,7 @@
[:license
[:name "ISC License"]
[:url "https://opensource.org/license/isc-license-txt"]]]]})
- (b/copy-dir {:src-dirs ["src" "resources"]
+ (b/copy-dir {:src-dirs ["src" "resources" "tools-analyzer"]
:target-dir class-dir
:replace {}})
(package-clerk-asset-map {:target-dir class-dir})
diff --git a/deps.edn b/deps.edn
index 9a2f68ceb..c8a0c1a3d 100644
--- a/deps.edn
+++ b/deps.edn
@@ -1,10 +1,11 @@
-{:paths ["src" "resources" "bb"]
+{:paths ["src" "resources" "bb" "tools-analyzer"]
:deps {org.clojure/clojure {:mvn/version "1.10.3"}
org.clojure/java.classpath {:mvn/version "1.0.0"}
org.clojure/tools.analyzer {:mvn/version "1.2.0"}
- org.clojure/tools.analyzer.jvm {:mvn/version "1.3.0"}
+ ;; org.clojure/tools.analyzer.jvm {:mvn/version "1.3.0"}
+ org.ow2.asm/asm {:mvn/version "9.2"} ;; tools.analyzer dependency
babashka/fs {:mvn/version "0.5.22"}
- borkdude/edamame {:mvn/version "1.4.24"}
+ borkdude/edamame {:mvn/version "1.4.28"}
weavejester/dependency {:mvn/version "0.2.1"}
com.nextjournal/beholder {:mvn/version "1.0.2"}
org.flatland/ordered {:mvn/version "1.15.12"}
@@ -39,7 +40,7 @@
:sci {:extra-deps {io.github.nextjournal/clerk.render {:local/root "render"}}}
- :dev {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0-beta1"} ;; for `:as-alias` & `add-lib` support but only in dev
+ :dev {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0"} ;; for `:as-alias` & `add-lib` support but only in dev
arrowic/arrowic {:mvn/version "0.1.1"}
binaryage/devtools {:mvn/version "1.0.3"}
cider/cider-nrepl {:mvn/version "0.49.3"}
@@ -75,6 +76,8 @@
;; Run a single test:
;; clj -M:test -v nextjournal.clerk.analyzer-test/analyze-doc
:main-opts ["-m" "cognitect.test-runner"]}
+ :1.10.3 {:extra-deps {org.clojure/clojure {:mvn/version "1.10.3"}}}
+ :1.12.0 {:extra-deps {org.clojure/clojure {:mvn/version "1.12.0"}}}
:demo {:extra-paths ["demo"]
:extra-deps {com.github.seancorfield/next.jdbc {:mvn/version "1.2.659"}
diff --git a/notebooks/clojure_1_12.clj b/notebooks/clojure_1_12.clj
new file mode 100644
index 000000000..eb6a52414
--- /dev/null
+++ b/notebooks/clojure_1_12.clj
@@ -0,0 +1,19 @@
+(ns clojure-1-12)
+
+(String/.length "foo")
+
+(map String/.length ["f" "fo" "foo"])
+
+String/1
+
+Integer/parseInt ;; method value
+
+String/CASE_INSENSITIVE_ORDER ;; field
+
+(String/new "dude") ;; constructor
+
+^[String] String/new
+
+(map ^[String] String/new ["dude"])
+
+(map Integer/parseInt ["1" "2" "3"])
diff --git a/src/nextjournal/clerk/analyzer.clj b/src/nextjournal/clerk/analyzer.clj
index b8874be4c..694d49d80 100644
--- a/src/nextjournal/clerk/analyzer.clj
+++ b/src/nextjournal/clerk/analyzer.clj
@@ -8,13 +8,13 @@
[clojure.string :as str]
[clojure.tools.analyzer :as ana]
[clojure.tools.analyzer.ast :as ana-ast]
- [clojure.tools.analyzer.jvm :as ana-jvm]
[clojure.tools.analyzer.utils :as ana-utils]
[multiformats.base.b58 :as b58]
[multiformats.hash :as hash]
- [nextjournal.clerk.parser :as parser]
[nextjournal.clerk.classpath :as cp]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm :as ana-jvm]
[nextjournal.clerk.config :as config]
+ [nextjournal.clerk.parser :as parser]
[nextjournal.clerk.walk :as walk]
[taoensso.nippy :as nippy]
[weavejester.dependency :as dep]))
diff --git a/test/nextjournal/clerk/clojure_1_12_test.clj b/test/nextjournal/clerk/clojure_1_12_test.clj
new file mode 100644
index 000000000..50b604dfb
--- /dev/null
+++ b/test/nextjournal/clerk/clojure_1_12_test.clj
@@ -0,0 +1,8 @@
+(ns nextjournal.clerk.clojure-1-12-test
+ (:require [clojure.test :as t :refer [deftest is]]
+ [nextjournal.clerk :as clerk]))
+
+(when (>= (:minor *clojure-version*) 12)
+ (deftest notebook-is-analyzed-without-errors-test
+ (is (do (clerk/show! "notebooks/clojure_1_12.clj")
+ true))))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/core/cache.clj b/tools-analyzer/nextjournal/clerk/clojure/core/cache.clj
new file mode 100644
index 000000000..07585c87d
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/core/cache.clj
@@ -0,0 +1,658 @@
+; Copyright (c) Rich Hickey. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+(ns ^{:doc "A caching library for Clojure."
+ :author "Fogus"}
+ nextjournal.clerk.clojure.core.cache
+ (:require [nextjournal.clerk.clojure.data.priority-map :as clojure.data.priority-map])
+ (:import (java.lang.ref ReferenceQueue SoftReference)
+ (java.util.concurrent ConcurrentHashMap)))
+
+(set! *warn-on-reflection* true)
+
+;; # Protocols and Types
+
+(defprotocol CacheProtocol
+ "This is the protocol describing the basic cache capability."
+ (lookup [cache e]
+ [cache e not-found]
+ "Retrieve the value associated with `e` if it exists, else `nil` in
+ the 2-arg case. Retrieve the value associated with `e` if it exists,
+ else `not-found` in the 3-arg case.")
+ (has? [cache e]
+ "Checks if the cache contains a value associated with `e`")
+ (hit [cache e]
+ "Is meant to be called if the cache is determined to contain a value
+ associated with `e`")
+ (miss [cache e ret]
+ "Is meant to be called if the cache is determined to **not** contain a
+ value associated with `e`")
+ (evict [cache e]
+ "Removes an entry from the cache")
+ (seed [cache base]
+ "Is used to signal that the cache should be created with a seed.
+ The contract is that said cache should return an instance of its
+ own type."))
+
+(def ^{:private true} default-wrapper-fn #(%1 %2))
+
+(defn through
+ "The basic hit/miss logic for the cache system. Expects a wrap function and
+ value function. The wrap function takes the value function and the item in question
+ and is expected to run the value function with the item whenever a cache
+ miss occurs. The intent is to hide any cache-specific cells from leaking
+ into the cache logic itelf."
+ ([cache item] (through default-wrapper-fn identity cache item))
+ ([value-fn cache item] (through default-wrapper-fn value-fn cache item))
+ ([wrap-fn value-fn cache item]
+ (if (nextjournal.clerk.clojure.core.cache/has? cache item)
+ (nextjournal.clerk.clojure.core.cache/hit cache item)
+ (nextjournal.clerk.clojure.core.cache/miss cache item (wrap-fn #(value-fn %) item)))))
+
+(defn through-cache
+ "The basic hit/miss logic for the cache system. Like through but always has
+ the cache argument in the first position for easier use with swap! etc."
+ ([cache item] (through-cache cache item default-wrapper-fn identity))
+ ([cache item value-fn] (through-cache cache item default-wrapper-fn value-fn))
+ ([cache item wrap-fn value-fn]
+ (if (nextjournal.clerk.clojure.core.cache/has? cache item)
+ (nextjournal.clerk.clojure.core.cache/hit cache item)
+ (nextjournal.clerk.clojure.core.cache/miss cache item (wrap-fn #(value-fn %) item)))))
+
+(defmacro defcache
+ [type-name fields & specifics]
+ (let [[base & _] fields
+ base-field (with-meta base {:tag 'clojure.lang.IPersistentMap})]
+ `(deftype ~type-name [~@fields]
+ ~@specifics
+
+ clojure.lang.ILookup
+ (valAt [this# key#]
+ (lookup this# key#))
+ (valAt [this# key# not-found#]
+ (if (has? this# key#)
+ (lookup this# key#)
+ not-found#))
+
+ java.lang.Iterable
+ (iterator [_#]
+ (.iterator ~base-field))
+
+ clojure.lang.IPersistentMap
+ (assoc [this# k# v#]
+ (miss this# k# v#))
+ (without [this# k#]
+ (evict this# k#))
+
+ clojure.lang.Associative
+ (containsKey [this# k#]
+ (has? this# k#))
+ (entryAt [this# k#]
+ (when (has? this# k#)
+ (clojure.lang.MapEntry. k# (lookup this# k#))))
+
+ clojure.lang.Counted
+ (count [this#]
+ (count ~base-field))
+
+ clojure.lang.IPersistentCollection
+ (cons [this# elem#]
+ (seed this# (conj ~base-field elem#)))
+ (empty [this#]
+ (seed this# (empty ~base-field)))
+ (equiv [this# other#]
+ (= other# ~base-field))
+
+ clojure.lang.Seqable
+ (seq [_#]
+ (seq ~base-field)))))
+
+(defcache BasicCache [cache]
+ CacheProtocol
+ (lookup [_ item]
+ (get cache item))
+ (lookup [_ item not-found]
+ (get cache item not-found))
+ (has? [_ item]
+ (contains? cache item))
+ (hit [this item] this)
+ (miss [_ item result]
+ (BasicCache. (assoc cache item result)))
+ (evict [_ key]
+ (BasicCache. (dissoc cache key)))
+ (seed [_ base]
+ (BasicCache. base))
+ Object
+ (toString [_] (str cache)))
+
+;; FnCache
+
+(defcache FnCache [cache f]
+ CacheProtocol
+ (lookup [_ item]
+ (f (get cache item)))
+ (lookup [_ item not-found]
+ (let [ret (get cache item not-found)]
+ (if (= not-found ret)
+ not-found
+ (f ret))))
+ (has? [_ item]
+ (contains? cache item))
+ (hit [this item] this)
+ (miss [_ item result]
+ (BasicCache. (assoc cache item result)))
+ (evict [_ key]
+ (BasicCache. (dissoc cache key)))
+ (seed [_ base]
+ (BasicCache. base))
+ Object
+ (toString [_] (str cache)))
+
+;; # FIFO
+
+(defn- describe-layout [mappy limit]
+ (let [ks (keys mappy)
+ [dropping keeping] (split-at (- (count ks) limit) ks)]
+ {:dropping dropping
+ :keeping keeping
+ :queue
+ (-> clojure.lang.PersistentQueue/EMPTY
+ (into (repeat (- limit (count keeping)) ::free))
+ (into (take limit keeping)))}))
+
+(defn- prune-queue [q k]
+ (reduce (fn [q e] (if (#{k} e) q (conj q e)))
+ (conj clojure.lang.PersistentQueue/EMPTY ::free)
+ q))
+
+(defcache FIFOCache [cache q limit]
+ CacheProtocol
+ (lookup [_ item]
+ (get cache item))
+ (lookup [_ item not-found]
+ (get cache item not-found))
+ (has? [_ item]
+ (contains? cache item))
+ (hit [this item]
+ this)
+ (miss [_ item result]
+ (let [[kache qq] (let [k (peek q)]
+ (if (>= (count cache) limit)
+ [(dissoc cache k) (pop q)]
+ [cache (pop q)]))]
+ (FIFOCache. (assoc kache item result)
+ (conj qq item)
+ limit)))
+ (evict [this key]
+ (if (contains? cache key)
+ (FIFOCache. (dissoc cache key)
+ (prune-queue q key)
+ limit)
+ this))
+ (seed [_ base]
+ (let [{dropping :dropping
+ q :queue} (describe-layout base limit)]
+ (FIFOCache. (apply dissoc base dropping)
+ q
+ limit)))
+ Object
+ (toString [_]
+ (str cache \, \space (pr-str q))))
+
+(defn- build-leastness-queue
+ [base start-at]
+ (into (clojure.data.priority-map/priority-map) (for [[k _] base] [k start-at])))
+
+(defcache LRUCache [cache lru tick limit]
+ CacheProtocol
+ (lookup [_ item]
+ (get cache item))
+ (lookup [_ item not-found]
+ (get cache item not-found))
+ (has? [_ item]
+ (contains? cache item))
+ (hit [_ item]
+ (let [tick+ (inc tick)]
+ (LRUCache. cache
+ (if (contains? cache item)
+ (assoc lru item tick+)
+ lru)
+ tick+
+ limit)))
+ (miss [_ item result]
+ (let [tick+ (inc tick)]
+ (if (>= (count lru) limit)
+ (let [k (if (contains? lru item)
+ item
+ (first (peek lru))) ;; minimum-key, maybe evict case
+ c (-> cache (dissoc k) (assoc item result))
+ l (-> lru (dissoc k) (assoc item tick+))]
+ (LRUCache. c l tick+ limit))
+ (LRUCache. (assoc cache item result) ;; no change case
+ (assoc lru item tick+)
+ tick+
+ limit))))
+ (evict [this key]
+ (if (contains? cache key)
+ (LRUCache. (dissoc cache key)
+ (dissoc lru key)
+ (inc tick)
+ limit)
+ this))
+ (seed [_ base]
+ (LRUCache. base
+ (build-leastness-queue base 0)
+ 0
+ limit))
+ Object
+ (toString [_]
+ (str cache \, \space lru \, \space tick \, \space limit)))
+
+
+(defn- key-killer-q
+ [ttl q expiry now]
+ (let [[ks q'] (reduce (fn [[ks q] [k g t]]
+ (if (> (- now t) expiry)
+ (if (= g (first (get ttl k)))
+ [(conj ks k) (pop q)]
+ [ks (pop q)])
+ (reduced [ks q])))
+ [[] q]
+ q)]
+ [#(apply dissoc % ks) q']))
+
+(defcache TTLCacheQ [cache ttl q gen ttl-ms]
+ CacheProtocol
+ (lookup [this item]
+ (let [ret (lookup this item ::nope)]
+ (when-not (= ::nope ret) ret)))
+ (lookup [this item not-found]
+ (if (has? this item)
+ (get cache item)
+ not-found))
+ (has? [_ item]
+ (and (let [[_ t] (get ttl item [0 (- ttl-ms)])]
+ (< (- (System/currentTimeMillis)
+ t)
+ ttl-ms))
+ (contains? cache item)))
+ (hit [this item] this)
+ (miss [this item result]
+ (let [now (System/currentTimeMillis)
+ [kill-old q'] (key-killer-q ttl q ttl-ms now)]
+ (TTLCacheQ. (assoc (kill-old cache) item result)
+ (assoc (kill-old ttl) item [gen now])
+ (conj q' [item gen now])
+ (unchecked-inc gen)
+ ttl-ms)))
+ (seed [_ base]
+ (let [now (System/currentTimeMillis)]
+ (TTLCacheQ. base
+ ;; we seed the cache all at gen, but subsequent entries
+ ;; will get gen+1, gen+2 etc
+ (into {} (for [x base] [(key x) [gen now]]))
+ (into q (for [x base] [(key x) gen now]))
+ (unchecked-inc gen)
+ ttl-ms)))
+ (evict [_ key]
+ (TTLCacheQ. (dissoc cache key)
+ (dissoc ttl key)
+ q
+ gen
+ ttl-ms))
+ Object
+ (toString [_]
+ (str cache \, \space ttl \, \space ttl-ms)))
+
+
+(defcache LUCache [cache lu limit]
+ CacheProtocol
+ (lookup [_ item]
+ (get cache item))
+ (lookup [_ item not-found]
+ (get cache item not-found))
+ (has? [_ item]
+ (contains? cache item))
+ (hit [_ item]
+ (LUCache. cache (update-in lu [item] inc) limit))
+ (miss [_ item result]
+ (if (>= (count lu) limit) ;; need to evict?
+ (let [min-key (if (contains? lu item)
+ ::nope
+ (first (peek lu))) ;; maybe evict case
+ c (-> cache (dissoc min-key) (assoc item result))
+ l (-> lu (dissoc min-key) (update-in [item] (fnil inc 0)))]
+ (LUCache. c l limit))
+ (LUCache. (assoc cache item result) ;; no change case
+ (update-in lu [item] (fnil inc 0))
+ limit)))
+ (evict [this key]
+ (if (contains? this key)
+ (LUCache. (dissoc cache key)
+ (dissoc lu key)
+ limit)
+ this))
+ (seed [_ base]
+ (LUCache. base
+ (build-leastness-queue base 0)
+ limit))
+ Object
+ (toString [_]
+ (str cache \, \space lu \, \space limit)))
+
+
+;; # LIRS
+;; *initial Clojure implementation by Jan Oberhagemann*
+
+;; A
+;; [LIRS](http://citeseer.ist.psu.edu/viewdoc/summary?doi=10.1.1.116.2184)
+;; cache consists of two LRU lists, `S` and `Q`, and keeps more history
+;; than a LRU cache. Every cached item is either a LIR, HIR or
+;; non-resident HIR block. `Q` contains only HIR blocks, `S` contains
+;; LIR, HIR, non-resident HIR blocks. The total cache size is
+;; |`S`|+|`Q`|, |`S`| is typically 99% of the cache size.
+
+;; * LIR block:
+;; Low Inter-Reference block, a cached item with a short interval
+;; between accesses. A block `x`, `x` โ `S` โง `x` โ `Q` โง `x` โ
+;; `cache`, is a LIR block.
+
+;; * HIR block:
+;; High Inter-Reference block, a cached item with rare accesses and
+;; long interval. A block `x`, `x` โ `Q` โง `x` โ `cache`, is a HIR block.
+
+;; * non-resident HIR block:
+;; only the key of the HIR block is cached, without the corresponding
+;; value a test (has?) for the corresponding key is always a
+;; miss. Used for additional history information. A block `x`, `x` โ
+;; `S` โง `x` โ `Q` โง `x` โ `cache`, is a non-resident HIR block.
+
+;; ## Outline of the implemented algorithm
+
+;; `cache` is used to store the key value pairs.
+;; `S` and `Q` maintain the relative order of accesses of the keys, like
+;; a LRU list.
+
+;; Definition of `prune stack`:
+;;
+;; repeatedly remove oldest item from S until an item k, k โ Q โง
+;; k โ cache (a LIR block), is found
+
+
+;; In case of a miss for key `k` and value `v` (`k` โ cache) and
+;;
+;; * (1.1) `S` is not filled, |`S`| < `limitS`
+;; add k to S
+;; add k to the cache
+
+;; * (1.2) `k` โ `S`, never seen or not seen for a long, long time
+;; remove oldest item x from Q
+;; remove x from cache
+;; add k to S
+;; add k to Q
+;; add k to the cache
+
+;; * (1.3) `k` โ `S`, this is a non-resident HIR block
+;; remove oldest item x from Q
+;; remove x from cache
+;; add k to S
+;; remove oldest item y from S
+;; add y to Q
+;; prune stack
+
+
+;; In case of a hit for key `k` (`k` โ cache) and
+
+;; * (2.1) `k` โ `S` โง `k` โ `Q`, a LIR block
+;; add k to S / refresh
+;; prune stack if k was the oldest item in S
+
+;; * (2.2) `k` โ `S` โง `k` โ `Q`, a HIR block
+;; add k to S / refresh
+;; remove k from Q
+;; remove oldest item x from S
+;; add x to Q
+;; prune stack
+
+;; * (2.3) `k` โ `S` โง `k` โ `Q`, a HIR block, only older than the oldest item in S
+;; add k to S
+;; add k to Q / refresh
+
+(defn- prune-stack [lruS lruQ cache]
+ (loop [s lruS q lruQ c cache]
+ (let [k (apply min-key s (keys s))]
+ (if (or (contains? q k) ; HIR item
+ (not (contains? c k))) ; non-resident HIR item
+ (recur (dissoc s k) q c)
+ s))))
+
+(defcache LIRSCache [cache lruS lruQ tick limitS limitQ]
+ CacheProtocol
+ (lookup [_ item]
+ (get cache item))
+ (lookup [_ item not-found]
+ (get cache item not-found))
+ (has? [_ item]
+ (contains? cache item))
+ (hit [_ item]
+ (let [tick+ (inc tick)]
+ (if (not (contains? lruS item))
+ ; (2.3) item โ S โง item โ Q
+ (LIRSCache. cache (assoc lruS item tick+) (assoc lruQ item tick+) tick+ limitS limitQ)
+ (let [k (apply min-key lruS (keys lruS))]
+ (if (contains? lruQ item)
+ ; (2.2) item โ S โง item โ Q
+ (let [new-lruQ (-> lruQ (dissoc item) (assoc k tick+))]
+ (LIRSCache. cache
+ (-> lruS (dissoc k) (assoc item tick+) (prune-stack new-lruQ cache))
+ new-lruQ
+ tick+
+ limitS
+ limitQ))
+ ; (2.1) item โ S โง item โ Q
+ (LIRSCache. cache
+ (-> lruS (assoc item tick+) (prune-stack lruQ cache))
+ lruQ
+ tick+
+ limitS
+ limitQ))))))
+
+ (miss [_ item result]
+ (let [tick+ (inc tick)]
+ (if (< (count cache) limitS)
+ ; (1.1)
+ (let [k (apply min-key lruS (keys lruS))]
+ (LIRSCache. (assoc cache item result)
+ (-> lruS (dissoc k) (assoc item tick+))
+ lruQ
+ tick+
+ limitS
+ limitQ))
+ (let [k (apply min-key lruQ (keys lruQ))
+ new-lruQ (dissoc lruQ k)
+ new-cache (-> cache (dissoc k) (assoc item result))]
+ (if (contains? lruS item)
+ ; (1.3)
+ (let [lastS (apply min-key lruS (keys lruS))]
+ (LIRSCache. new-cache
+ (-> lruS (dissoc lastS) (assoc item tick+) (prune-stack new-lruQ new-cache))
+ (assoc new-lruQ lastS tick+)
+ tick+
+ limitS
+ limitQ))
+ ; (1.2)
+ (LIRSCache. new-cache
+ (assoc lruS item tick+)
+ (assoc new-lruQ item tick+)
+ tick+
+ limitS
+ limitQ))))))
+ (seed [_ base]
+ (LIRSCache. base
+ (into {} (for [x (range (- limitS) 0)] [x x]))
+ (into {} (for [x (range (- limitQ) 0)] [x x]))
+ 0
+ limitS
+ limitQ))
+ Object
+ (toString [_]
+ (str cache \, \space lruS \, \space lruQ \, \space tick \, \space limitS \, \space limitQ)))
+
+(defn clear-soft-cache! [^java.util.Map cache ^java.util.Map rcache ^ReferenceQueue rq]
+ (loop [r (.poll rq)]
+ (when r
+ (when-let [item (get rcache r)]
+ (.remove cache item))
+ (.remove rcache r)
+ (recur (.poll rq)))))
+
+(defn make-reference [v rq]
+ (if (nil? v)
+ (SoftReference. ::nil rq)
+ (SoftReference. v rq)))
+
+(defcache SoftCache [^java.util.Map cache ^java.util.Map rcache rq]
+ CacheProtocol
+ (lookup [_ item]
+ (when-let [^SoftReference r (get cache (or item ::nil))]
+ (let [v (.get r)]
+ (if (= ::nil v)
+ nil
+ v))))
+ (lookup [_ item not-found]
+ (if-let [^SoftReference r (get cache (or item ::nil))]
+ (if-let [v (.get r)]
+ (if (= ::nil v)
+ nil
+ v)
+ not-found)
+ not-found))
+ (has? [_ item]
+ (let [item (or item ::nil)
+ ^SoftReference cell (get cache item)]
+ (boolean
+ (when cell
+ (not (nil? (.get cell)))))))
+ (hit [this item]
+ (clear-soft-cache! cache rcache rq)
+ this)
+ (miss [this item result]
+ (let [item (or item ::nil)
+ r (make-reference result rq)]
+ (.put cache item r)
+ (.put rcache r item)
+ (clear-soft-cache! cache rcache rq)
+ this))
+ (evict [this key]
+ (let [key (or key ::nil)
+ r (get cache key)]
+ (when r
+ (.remove cache key)
+ (.remove rcache r))
+ (clear-soft-cache! cache rcache rq)
+ this))
+ (seed [_ base]
+ (let [soft-cache? (instance? SoftCache base)
+ cache (ConcurrentHashMap.)
+ rcache (ConcurrentHashMap.)
+ rq (ReferenceQueue.)]
+ (if (seq base)
+ (doseq [[k ^SoftReference v] base]
+ (let [k (or k ::nil)
+ r (if soft-cache?
+ (make-reference (.get v) rq)
+ (make-reference v rq))]
+ (.put cache k r)
+ (.put rcache r k))))
+ (SoftCache. cache rcache rq)))
+ Object
+ (toString [_] (str cache)))
+
+;; Factories
+
+(defn basic-cache-factory
+ "Returns a pluggable basic cache initialized to `base`"
+ [base]
+ {:pre [(map? base)]}
+ (BasicCache. base))
+
+(defn fifo-cache-factory
+ "Returns a FIFO cache with the cache and FIFO queue initialized to `base` --
+ the queue is filled as the values are pulled out of `base`. If the associative
+ structure can guarantee ordering, then the said ordering will define the
+ eventual eviction order. Otherwise, there are no guarantees for the eventual
+ eviction ordering.
+
+ This function takes an optional `:threshold` argument that defines the maximum number
+ of elements in the cache before the FIFO semantics apply (default is 32).
+
+ If the number of elements in `base` is greater than the limit then some items
+ in `base` will be dropped from the resulting cache. If the associative
+ structure used as `base` can guarantee sorting, then the last `limit` elements
+ will be used as the cache seed values. Otherwise, there are no guarantees about
+ the elements in the resulting cache."
+ [base & {threshold :threshold :or {threshold 32}}]
+ {:pre [(number? threshold) (< 0 threshold)
+ (map? base)]
+ :post [(== threshold (count (.q ^FIFOCache %)))]}
+ (nextjournal.clerk.clojure.core.cache/seed (FIFOCache. {} clojure.lang.PersistentQueue/EMPTY threshold) base))
+
+(defn lru-cache-factory
+ "Returns an LRU cache with the cache and usage-table initialized to `base` --
+ each entry is initialized with the same usage value.
+
+ This function takes an optional `:threshold` argument that defines the maximum number
+ of elements in the cache before the LRU semantics apply (default is 32)."
+ [base & {threshold :threshold :or {threshold 32}}]
+ {:pre [(number? threshold) (< 0 threshold)
+ (map? base)]}
+ (nextjournal.clerk.clojure.core.cache/seed (LRUCache. {} (clojure.data.priority-map/priority-map) 0 threshold) base))
+
+(defn ttl-cache-factory
+ "Returns a TTL cache with the cache and expiration-table initialized to `base` --
+ each with the same time-to-live.
+
+ This function also allows an optional `:ttl` argument that defines the default
+ time in milliseconds that entries are allowed to reside in the cache."
+ [base & {ttl :ttl :or {ttl 2000}}]
+ {:pre [(number? ttl) (<= 0 ttl)
+ (map? base)]}
+ (nextjournal.clerk.clojure.core.cache/seed (TTLCacheQ. {} {} clojure.lang.PersistentQueue/EMPTY 0 ttl) base))
+
+(defn lu-cache-factory
+ "Returns an LU cache with the cache and usage-table initialized to `base`.
+
+ This function takes an optional `:threshold` argument that defines the maximum number
+ of elements in the cache before the LU semantics apply (default is 32)."
+ [base & {threshold :threshold :or {threshold 32}}]
+ {:pre [(number? threshold) (< 0 threshold)
+ (map? base)]}
+ (nextjournal.clerk.clojure.core.cache/seed (LUCache. {} (clojure.data.priority-map/priority-map) threshold) base))
+
+(defn lirs-cache-factory
+ "Returns an LIRS cache with the S & R LRU lists set to the indicated
+ limits."
+ [base & {:keys [s-history-limit q-history-limit]
+ :or {s-history-limit 32
+ q-history-limit 32}}]
+ {:pre [(number? s-history-limit) (< 0 s-history-limit)
+ (number? q-history-limit) (< 0 q-history-limit)
+ (map? base)]}
+ (nextjournal.clerk.clojure.core.cache/seed (LIRSCache. {} {} {} 0 s-history-limit q-history-limit) base))
+
+(defn soft-cache-factory
+ "Returns a SoftReference cache. Cached values will be referred to with
+ SoftReferences, allowing the values to be garbage collected when there is
+ memory pressure on the JVM.
+
+ SoftCache is a mutable cache, since it is always based on a
+ ConcurrentHashMap."
+ [base]
+ {:pre [(map? base)]}
+ (nextjournal.clerk.clojure.core.cache/seed (SoftCache. (ConcurrentHashMap.) (ConcurrentHashMap.) (ReferenceQueue.))
+ base))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/core/memoize.clj b/tools-analyzer/nextjournal/clerk/clojure/core/memoize.clj
new file mode 100644
index 000000000..1dddf0c4d
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/core/memoize.clj
@@ -0,0 +1,509 @@
+; Copyright (c) Rich Hickey and Michael Fogus. All rights reserved.
+; The use and distribution terms for this software are covered by the
+; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+; which can be found in the file epl-v10.html at the root of this distribution.
+; By using this software in any fashion, you are agreeing to be bound by
+; the terms of this license.
+; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.core.memoize
+ "core.memoize is a memoization library offering functionality above
+ Clojure's core `memoize` function in the following ways:
+
+ **Pluggable memoization**
+
+ core.memoize allows for different back-end cache implmentations to
+ be used as appropriate without changing the memoization modus operandi.
+ See the `memoizer` function.
+
+ **Manipulable memoization**
+
+ Because core.memoize allows you to access a function's memoization store,
+ you do interesting things like clear it, modify it, and save it for later.
+ "
+ {:author "fogus"}
+
+ (:require [nextjournal.clerk.clojure.core.cache :as cache]))
+
+
+
+;; Similar to clojure.lang.Delay, but will not memoize an exception and will
+;; instead retry.
+;; fun - the function, never nil
+;; available? - indicates a memoized value is available, volatile for visibility
+;; value - the value (if available) - volatile for visibility
+(deftype RetryingDelay [fun ^:volatile-mutable available? ^:volatile-mutable value]
+ clojure.lang.IDeref
+ (deref [this]
+ ;; first check (safe with volatile flag)
+ (if available?
+ value
+ (locking fun
+ ;; second check (race condition with locking)
+ (if available?
+ value
+ (do
+ ;; fun may throw - will retry on next deref
+ (let [v (fun)]
+ ;; this ordering is important - MUST set value before setting available?
+ ;; or you have a race with the first check above
+ (set! value v)
+ (set! available? true)
+ v))))))
+ clojure.lang.IPending
+ (isRealized [this]
+ available?))
+
+(defn- d-lay [fun]
+ (->RetryingDelay fun false nil))
+
+(defn- make-derefable
+ "If a value is not already derefable, wrap it up.
+
+ This is used to help rebuild seed/base maps passed in to the various
+ caches so that they conform to core.memoize's world view."
+ [v]
+ (if (instance? clojure.lang.IDeref v)
+ v
+ (reify clojure.lang.IDeref
+ (deref [_] v))))
+
+(defn- derefable-seed
+ "Given a seed/base map, ensure all the values in it are derefable."
+ [seed]
+ (into {} (for [[k v] seed] [k (make-derefable v)])))
+
+;; Plugging Interface
+
+(deftype PluggableMemoization [f cache]
+ cache/CacheProtocol
+ (has? [_ item]
+ (nextjournal.clerk.clojure.core.cache/has? cache item))
+ (hit [_ item]
+ (PluggableMemoization. f (nextjournal.clerk.clojure.core.cache/hit cache item)))
+ (miss [_ item result]
+ (PluggableMemoization. f (nextjournal.clerk.clojure.core.cache/miss cache item result)))
+ (evict [_ key]
+ (PluggableMemoization. f (nextjournal.clerk.clojure.core.cache/evict cache key)))
+ (lookup [_ item]
+ (nextjournal.clerk.clojure.core.cache/lookup cache item nil))
+ (lookup [_ item not-found]
+ (nextjournal.clerk.clojure.core.cache/lookup cache item (delay not-found)))
+ (seed [_ base]
+ (PluggableMemoization.
+ f (nextjournal.clerk.clojure.core.cache/seed cache (derefable-seed base))))
+ Object
+ (toString [_] (str cache)))
+
+;; # Auxilliary functions
+
+(def ^{:private true
+ :doc "Returns a function's argument transformer."}
+ args-fn #(or (::args-fn (meta %)) identity))
+
+(defn- through*
+ "The basic hit/miss logic for the cache system based on `core.cache/through`.
+ Clojure delays are used to hold the cache value."
+ [cache f args item]
+ (nextjournal.clerk.clojure.core.cache/through
+ (fn [f _] (d-lay #(f args)))
+ #(clojure.core/apply f %)
+ cache
+ item))
+
+(def ^{:private true
+ :doc "Returns a function's cache identity."}
+ cache-id #(::cache (meta %)))
+
+
+;; # Public Utilities API
+
+(defn snapshot
+ "Returns a snapshot of a core.memo-placed memoization cache. By snapshot
+ you can infer that what you get is only the cache contents at a
+ moment in time."
+ [memoized-fn]
+ (when-let [cache (cache-id memoized-fn)]
+ (into {}
+ (for [[k v] (.cache ^PluggableMemoization @cache)]
+ [(vec k) @v]))))
+
+(defn lazy-snapshot
+ "Returns a lazy snapshot of a core.memo-placed memoization cache. By
+ lazy snapshot you can infer that what you get is only the cache contents at a
+ moment in time -- and, being lazy, the cache could change while you are
+ realizing the snapshot elements.
+
+ Returns a sequence of key/value pairs."
+ [memoized-fn]
+ (when-let [cache (cache-id memoized-fn)]
+ (for [[k v] (.cache ^PluggableMemoization @cache)]
+ [(vec k) @v])))
+
+(defn memoized?
+ "Returns true if a function has an core.memo-placed cache, false otherwise."
+ [f]
+ (boolean (cache-id f)))
+
+(defn memo-clear!
+ "Reaches into an core.memo-memoized function and clears the cache. This is a
+ destructive operation and should be used with care.
+
+ When the second argument is a vector of input arguments, clears cache only
+ for argument vector.
+
+ Keep in mind that depending on what other threads or doing, an
+ immediate call to `snapshot` may not yield an empty cache. That's
+ cool though, we've learned to deal with that stuff in Clojure by
+ now."
+ ([f]
+ (when-let [cache (cache-id f)]
+ (swap! cache (constantly (nextjournal.clerk.clojure.core.cache/seed @cache {})))))
+ ([f args]
+ (when-let [cache (cache-id f)]
+ (swap! cache (constantly (nextjournal.clerk.clojure.core.cache/evict @cache args))))))
+
+(defn memo-reset!
+ "Takes a core.memo-populated function and a map and replaces the memoization cache
+ with the supplied map. This is potentially some serious voodoo,
+ since you can effectively change the semantics of a function on the fly.
+
+ (def id (memo identity))
+ (memo-swap! id '{[13] :omg})
+ (id 13)
+ ;=> :omg
+
+ With great power comes ... yadda yadda yadda."
+ [f base]
+ (when-let [cache (cache-id f)]
+ (swap! cache
+ (constantly (nextjournal.clerk.clojure.core.cache/seed @cache (derefable-seed base))))))
+
+(defn memo-swap!
+ "The 2-arity version takes a core.memo-populated function and a map and
+ replaces the memoization cache with the supplied map. Use `memo-reset!`
+ instead for replacing the cache as this 2-arity version of `memo-swap!`
+ should be considered deprecated.
+
+ The 3+-arity version takes a core.memo-populated function and arguments
+ similar to what you would pass to `clojure.core/swap!` and performs a
+ `swap!` on the underlying cache. In order to satisfy core.memoize's
+ world view, the assumption is that you will generally be calling it like:
+
+ (def id (memo identity))
+ (memo-swap! id clojure.core.cache/miss [13] :omg)
+ (id 13)
+ ;=> :omg
+
+ You'll nearly always use `clojure.core.cache/miss` for this operation but
+ you could pass any function that would work on an immutable cache, such
+ as `evict` or `assoc` etc.
+
+ Be aware that `memo-swap!` assumes it can wrap each of the `results` values
+ in a `delay` so that items conform to `clojure.core.memoize`'s world view."
+ ([f base]
+ (when-let [cache (cache-id f)]
+ (swap! cache
+ (constantly (nextjournal.clerk.clojure.core.cache/seed @cache (derefable-seed base))))))
+ ([f swap-fn args & results]
+ (when-let [cache (cache-id f)]
+ (apply swap! cache swap-fn args (map #(delay %) results)))))
+
+(defn memo-unwrap
+ [f]
+ (::original (meta f)))
+
+(defn- cached-function
+ "Given a function, an atom containing a (pluggable memoization cache), and
+ and cache key function, return a new function that behaves like the original
+ function except it is cached, based on its arguments, with the cache and the
+ original function in its metadata."
+ [f cache-atom ckey-fn]
+ (with-meta
+ (fn [& args]
+ (let [ckey (or (ckey-fn args) [])
+ cs (swap! cache-atom through* f args ckey)
+ val (nextjournal.clerk.clojure.core.cache/lookup cs ckey ::not-found)]
+ ;; If `lookup` returns `(delay ::not-found)`, it's likely that
+ ;; we ran into a timing issue where eviction and access
+ ;; are happening at about the same time. Therefore, we retry
+ ;; the `swap!` (potentially several times).
+ ;;
+ ;; core.memoize currently wraps all of its values in a `delay`.
+ (when val
+ (loop [n 0 v @val]
+ (if (= ::not-found v)
+ (when-let [v' (nextjournal.clerk.clojure.core.cache/lookup
+ (swap! cache-atom through* f args ckey)
+ ckey ::not-found)]
+ (when (< n 10)
+ (recur (inc n) @v')))
+ v)))))
+ {::cache cache-atom
+ ::original f}))
+
+;; # Public memoization API
+
+(defn memoizer
+ "Build a pluggable memoized version of a function. Given a function and a
+ (pluggable memoized) cache, and an optional seed (hash map of arguments to
+ return values), return a cached version of that function.
+
+ If you want to build your own cached function, perhaps with combined caches
+ or customized caches, this is the preferred way to do so now."
+ ([f cache]
+ (let [cache (atom (PluggableMemoization. f cache))
+ ckey-fn (args-fn f)]
+ (cached-function f cache ckey-fn)))
+ ([f cache seed]
+ (let [cache (atom (nextjournal.clerk.clojure.core.cache/seed (PluggableMemoization. f cache)
+ (derefable-seed seed)))
+ ckey-fn (args-fn f)]
+ (cached-function f cache ckey-fn))))
+
+(defn build-memoizer
+ "Builds a function that, given a function, returns a pluggable memoized
+ version of it. `build-memoizer` takes a cache factory function, and the
+ arguments to that factory function -- at least one of those arguments
+ should be the function to be memoized (it's usually the first argument).
+
+ `memoizer` above is a simpler version of `build-memoizer` that 'does the
+ right thing' with a cache and a seed hash map. `build-memoizer` remains
+ for backward compatibility but should be considered deprecated."
+ ([cache-factory f & args]
+ (let [cache (atom (apply cache-factory f args))
+ ckey-fn (args-fn f)]
+ (cached-function f cache ckey-fn))))
+
+(defn memo
+ "Used as a more flexible alternative to Clojure's core `memoization`
+ function. Memoized functions built using `memo` will respond to
+ the core.memo manipulable memoization utilities. As a nice bonus,
+ you can use `memo` in place of `memoize` without any additional
+ changes, with the added guarantee that the memoized function will
+ only be called once for a given sequence of arguments (`memoize`
+ can call the function multiple times when concurrent calls are
+ made with the same sequence of arguments).
+
+ The default way to use this function is to simply supply a function
+ that will be memoized. Additionally, you may also supply a map
+ of the form `'{[42] 42, [108] 108}` where keys are a vector
+ mapping expected argument values to arity positions. The map values
+ are the return values of the memoized function.
+
+ If the supplied function has metadata containing an
+ `:clojure.core.memoize/args-fn` key, the value is assumed to be a
+ function that should be applied to the arguments to produce a
+ subset or transformed sequence of arguments that are used for the
+ key in the cache (the full, original arguments will still be used
+ to call the function). This allows you to memoize functions where
+ one or more arguments are irrelevant for memoization, such as the
+ `clojure.java.jdbc` functions, whose first argument may include
+ a (mutable) JDBC `Connection` object:
+
+ (memo/memo (with-meta jdbc/execute! {::memo/args-fn rest}))
+
+ You can access the memoization cache directly via the `:clojure.core.memoize/cache` key
+ on the memoized function's metadata. However, it is advised to
+ use the core.memo primitives instead as implementation details may
+ change over time."
+ ([f] (memo f {}))
+ ([f seed]
+ (memoizer f (cache/basic-cache-factory {}) seed)))
+
+;; ## Utilities
+
+(defn ^{:private true} !! [c]
+ (println "WARNING - Deprecated construction method for"
+ c
+ "cache; prefered way is:"
+ (str "(clojure.core.memoize/" c " function <:" c "/threshold num>)")))
+
+(defmacro ^{:private true} def-deprecated [nom ds & arities]
+ `(defn ~(symbol (str "memo-" (name nom))) ~ds
+ ~@(for [[args body] arities]
+ (list args `(!! (quote ~nom)) body))))
+
+(defmacro ^{:private true} massert [condition msg]
+ `(when-not ~condition
+ (throw (new AssertionError (str "clojure.core.memoize/" ~msg "\n" (pr-str '~condition))))))
+
+(defmacro ^{:private true} check-args [nom f base key threshold]
+ (when *assert*
+ (let [good-key (keyword nom "threshold")
+ key-error `(str "Incorrect threshold key " ~key)
+ fun-error `(str ~nom " expects a function as its first argument; given " ~f)
+ thresh-error `(str ~nom " expects an integer for its " ~good-key " argument; given " ~threshold)]
+ `(do (massert (= ~key ~good-key) ~key-error)
+ (massert (some #{clojure.lang.IFn
+ clojure.lang.AFn
+ java.lang.Runnable
+ java.util.concurrent.Callable}
+ (ancestors (class ~f)))
+ ~fun-error)
+ (massert (number? ~threshold) ~thresh-error)))))
+
+;; ## Main API functions
+
+;; ### FIFO
+
+(def-deprecated fifo
+ "DEPRECATED: Please use clojure.core.memoize/fifo instead."
+ ([f] (memo-fifo f 32 {}))
+ ([f limit] (memo-fifo f limit {}))
+ ([f limit base]
+ (memoizer f (cache/fifo-cache-factory {} :threshold limit) base)))
+
+(defn fifo
+ "Works the same as the basic memoization function (i.e. `memo`
+ and `core.memoize` except when a given threshold is breached.
+
+ Observe the following:
+
+ (require '[clojure.core.memoize :as memo])
+
+ (def id (memo/fifo identity :fifo/threshold 2))
+
+ (id 42)
+ (id 43)
+ (snapshot id)
+ ;=> {[42] 42, [43] 43}
+
+ As you see, the limit of `2` has not been breached yet, but
+ if you call again with another value, then it is:
+
+ (id 44)
+ (snapshot id)
+ ;=> {[44] 44, [43] 43}
+
+ That is, the oldest entry `42` is pushed out of the
+ memoization cache. This is the standard **F**irst **I**n
+ **F**irst **O**ut behavior."
+ ([f] (fifo f {} :fifo/threshold 32))
+ ([f base] (fifo f base :fifo/threshold 32))
+ ([f tkey threshold] (fifo f {} tkey threshold))
+ ([f base key threshold]
+ (check-args "fifo" f base key threshold)
+ (memoizer f (cache/fifo-cache-factory {} :threshold threshold) base)))
+
+;; ### LRU
+
+(def-deprecated lru
+ "DEPRECATED: Please use clojure.core.memoize/lru instead."
+ ([f] (memo-lru f 32))
+ ([f limit] (memo-lru f limit {}))
+ ([f limit base]
+ (memoizer f (cache/lru-cache-factory {} :threshold limit) base)))
+
+(defn lru
+ "Works the same as the basic memoization function (i.e. `memo`
+ and `core.memoize` except when a given threshold is breached.
+
+ Observe the following:
+
+ (require '[clojure.core.memoize :as memo])
+
+ (def id (memo/lru identity :lru/threshold 2))
+
+ (id 42)
+ (id 43)
+ (snapshot id)
+ ;=> {[42] 42, [43] 43}
+
+ At this point the cache has not yet crossed the set threshold
+ of `2`, but if you execute yet another call the story will
+ change:
+
+ (id 44)
+ (snapshot id)
+ ;=> {[44] 44, [43] 43}
+
+ At this point the operation of the LRU cache looks exactly
+ the same at the FIFO cache. However, the difference becomes
+ apparent on further use:
+
+ (id 43)
+ (id 0)
+ (snapshot id)
+ ;=> {[0] 0, [43] 43}
+
+ As you see, once again calling `id` with the argument `43`
+ will expose the LRU nature of the underlying cache. That is,
+ when the threshold is passed, the cache will expel the
+ **L**east **R**ecently **U**sed element in favor of the new."
+ ([f] (lru f {} :lru/threshold 32))
+ ([f base] (lru f base :lru/threshold 32))
+ ([f tkey threshold] (lru f {} tkey threshold))
+ ([f base key threshold]
+ (check-args "lru" f base key threshold)
+ (memoizer f (cache/lru-cache-factory {} :threshold threshold) base)))
+
+;; ### TTL
+
+(def-deprecated ttl
+ "DEPRECATED: Please use clojure.core.memoize/ttl instead."
+ ([f] (memo-ttl f 3000 {}))
+ ([f limit] (memo-ttl f limit {}))
+ ([f limit base]
+ (memoizer f (cache/ttl-cache-factory {} :ttl limit) base)))
+
+(defn ttl
+ "Unlike many of the other core.memo memoization functions,
+ `memo-ttl`'s cache policy is time-based rather than algorithmic
+ or explicit. When memoizing a function using `memo-ttl` you
+ should provide a **T**ime **T**o **L**ive parameter in
+ milliseconds.
+
+ (require '[clojure.core.memoize :as memo])
+
+ (def id (memo/ttl identity :ttl/threshold 5000))
+
+ (id 42)
+ (snapshot id)
+ ;=> {[42] 42}
+
+ ... wait 5 seconds ...
+ (id 43)
+ (snapshot id)
+ ;=> {[43] 43}
+
+ The expired cache entries will be removed on each cache **miss**."
+ ([f] (ttl f {} :ttl/threshold 32))
+ ([f base] (ttl f base :ttl/threshold 32))
+ ([f tkey threshold] (ttl f {} tkey threshold))
+ ([f base key threshold]
+ (check-args "ttl" f base key threshold)
+ (memoizer f (cache/ttl-cache-factory {} :ttl threshold) base)))
+
+;; ### LU
+
+(def-deprecated lu
+ "DEPRECATED: Please use clojure.core.memoize/lu instead."
+ ([f] (memo-lu f 32))
+ ([f limit] (memo-lu f limit {}))
+ ([f limit base]
+ (memoizer f (cache/lu-cache-factory {} :threshold limit) base)))
+
+(defn lu
+ "Similar to the implementation of memo-lru, except that this
+ function removes all cache values whose usage value is
+ smallest:
+
+ (require '[clojure.core.memoize :as memo])
+
+ (def id (memo/lu identity :lu/threshold 3))
+
+ (id 42)
+ (id 42)
+ (id 43)
+ (id 44)
+ (snapshot id)
+ ;=> {[44] 44, [42] 42}
+
+ The **L**east **U**sed values are cleared on cache misses."
+ ([f] (lu f {} :lu/threshold 32))
+ ([f base] (lu f base :lu/threshold 32))
+ ([f tkey threshold] (lu f {} tkey threshold))
+ ([f base key threshold]
+ (check-args "lu" f base key threshold)
+ (memoizer f (cache/lu-cache-factory {} :threshold threshold) base)))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/data/priority_map.clj b/tools-analyzer/nextjournal/clerk/clojure/data/priority_map.clj
new file mode 100644
index 000000000..62f6613e7
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/data/priority_map.clj
@@ -0,0 +1,510 @@
+;; Copyright (c) Mark Engelberg, Rich Hickey and contributors. All rights reserved.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+;; A priority map is a map from items to priorities,
+;; offering queue-like peek/pop as well as the map-like ability to
+;; easily reassign priorities and other conveniences.
+;; by Mark Engelberg (mark.engelberg@gmail.com)
+;; Last update - September 19, 2021
+
+(ns
+ ^{:author "Mark Engelberg",
+ :doc "A priority map is very similar to a sorted map, but whereas a sorted map produces a
+sequence of the entries sorted by key, a priority map produces the entries sorted by value.
+In addition to supporting all the functions a sorted map supports, a priority map
+can also be thought of as a queue of [item priority] pairs. To support usage as
+a versatile priority queue, priority maps also support conj/peek/pop operations.
+
+The standard way to construct a priority map is with priority-map:
+user=> (def p (priority-map :a 2 :b 1 :c 3 :d 5 :e 4 :f 3))
+#'user/p
+user=> p
+{:b 1, :a 2, :c 3, :f 3, :e 4, :d 5}
+
+So :b has priority 1, :a has priority 2, and so on.
+Notice how the priority map prints in an order sorted by its priorities (i.e., the map's values)
+
+We can use assoc to assign a priority to a new item:
+user=> (assoc p :g 1)
+{:b 1, :g 1, :a 2, :c 3, :f 3, :e 4, :d 5}
+
+or to assign a new priority to an extant item:
+user=> (assoc p :c 4)
+{:b 1, :a 2, :f 3, :c 4, :e 4, :d 5}
+
+We can remove an item from the priority map:
+user=> (dissoc p :e)
+{:b 1, :a 2, :c 3, :f 3, :d 5}
+
+An alternative way to add to the priority map is to conj a [item priority] pair:
+user=> (conj p [:g 0])
+{:g 0, :b 1, :a 2, :c 3, :f 3, :e 4, :d 5}
+
+or use into:
+user=> (into p [[:g 0] [:h 1] [:i 2]])
+{:g 0, :b 1, :h 1, :a 2, :i 2, :c 3, :f 3, :e 4, :d 5}
+
+Priority maps are countable:
+user=> (count p)
+6
+
+Like other maps, equivalence is based not on type, but on contents.
+In other words, just as a sorted-map can be equal to a hash-map,
+so can a priority-map.
+user=> (= p {:b 1, :a 2, :c 3, :f 3, :e 4, :d 5})
+true
+
+You can test them for emptiness:
+user=> (empty? (priority-map))
+true
+user=> (empty? p)
+false
+
+You can test whether an item is in the priority map:
+user=> (contains? p :a)
+true
+user=> (contains? p :g)
+false
+
+It is easy to look up the priority of a given item, using any of the standard map mechanisms:
+user=> (get p :a)
+2
+user=> (get p :g 10)
+10
+user=> (p :a)
+2
+user=> (:a p)
+2
+
+Priority maps derive much of their utility by providing priority-based seq.
+Note that no guarantees are made about the order in which items of the same priority appear.
+user=> (seq p)
+([:b 1] [:a 2] [:c 3] [:f 3] [:e 4] [:d 5])
+Because no guarantees are made about the order of same-priority items, note that
+rseq might not be an exact reverse of the seq. It is only guaranteed to be in
+descending order.
+user=> (rseq p)
+([:d 5] [:e 4] [:c 3] [:f 3] [:a 2] [:b 1])
+
+This means first/rest/next/for/map/etc. all operate in priority order.
+user=> (first p)
+[:b 1]
+user=> (rest p)
+([:a 2] [:c 3] [:f 3] [:e 4] [:d 5])
+
+Priority maps also support subseq and rsubseq, however, *you must use the subseq and rsubseq
+defined in the clojure.data.priority-map namespace*, which patches longstanding JIRA issue
+[CLJ-428](https://clojure.atlassian.net/browse/CLJ-428). These patched versions
+of subseq and rsubseq will work on Clojure's other sorted collections as well, so you can
+use them as a drop-in replacement for the subseq and rsubseq found in core.
+user=> (subseq p < 3)
+([:b 1] [:a 2])
+user=> (subseq p >= 3)
+([:c 3] [:f 3] [:e 4] [:d 5])
+user=> (subseq p >= 2 < 4)
+([:a 2] [:c 3] [:f 3])
+user=> (rsubseq p < 4)
+([:c 3] [:f 3] [:a 2] [:b 1])
+user=> (rsubseq p >= 4)
+([:d 5] [:e 4])
+
+Priority maps support metadata:
+user=> (meta (with-meta p {:extra :info}))
+{:extra :info}
+
+But perhaps most importantly, priority maps can also function as priority queues.
+peek, like first, gives you the first [item priority] pair in the collection.
+pop removes the first [item priority] from the collection.
+(Note that unlike rest, which returns a seq, pop returns a priority map).
+
+user=> (peek p)
+[:b 1]
+user=> (pop p)
+{:a 2, :c 3, :f 3, :e 4, :d 5}
+
+It is also possible to use a custom comparator:
+user=> (priority-map-by > :a 1 :b 2 :c 3)
+{:c 3, :b 2, :a 1}
+
+Sometimes, it is desirable to have a map where the values contain more information
+than just the priority. For example, let's say you want a map like:
+{:a [2 :apple], :b [1 :banana], :c [3 :carrot]}
+and you want to sort the map by the numeric priority found in the pair.
+
+A common mistake is to try to solve this with a custom comparator:
+(priority-map-by
+ (fn [[priority1 _] [priority2 _]] (< priority1 priority2))
+ :a [2 :apple], :b [1 :banana], :c [3 :carrot])
+
+This will not work! Although it may appear to work with these particular values, it is not safe.
+In Clojure, like Java, all comparators must be *total orders*,
+meaning that you can't have a tie unless the objects you are comparing are
+in fact equal. The above comparator breaks that rule because objects such as
+`[2 :apple]` and `[2 :apricot]` would tie, but are not equal.
+
+The correct way to construct such a priority map is by specifying a keyfn, which is used
+to extract the true priority from the priority map's vals. (Note: It might seem a little odd
+that the priority-extraction function is called a *key*fn, even though it is applied to the
+map's values. This terminology is based on the docstring of clojure.core/sort-by, which
+uses `keyfn` for the function which extracts the sort order.)
+
+In the above example,
+
+user=> (priority-map-keyfn first :a [2 :apple], :b [1 :banana], :c [3 :carrot])
+{:b [1 :banana], :a [2 :apple], :c [3 :carrot]}
+
+You can also combine a keyfn with a comparator that operates on the extracted priorities:
+
+user=> (priority-map-keyfn-by
+ first >
+ :a [2 :apple], :b [1 :banana], :c [3 :carrot])
+{:c [3 :carrot], :a [2 :apple], :b [1 :banana]}
+
+
+
+All of these operations are efficient. Generally speaking, most operations
+are O(log n) where n is the number of distinct priorities. Some operations
+(for example, straightforward lookup of an item's priority, or testing
+whether a given item is in the priority map) are as efficient
+as Clojure's built-in map.
+
+The key to this efficiency is that internally, not only does the priority map store
+an ordinary hash map of items to priority, but it also stores a sorted map that
+maps priorities to sets of items with that priority.
+
+A typical textbook priority queue data structure supports at the ability to add
+a [item priority] pair to the queue, and to pop/peek the next [item priority] pair.
+But many real-world applications of priority queues require more features, such
+as the ability to test whether something is already in the queue, or to reassign
+a priority. For example, a standard formulation of Dijkstra's algorithm requires the
+ability to reduce the priority number associated with a given item. Once you
+throw persistence into the mix with the desire to adjust priorities, the traditional
+structures just don't work that well.
+
+This particular blend of Clojure's built-in hash sets, hash maps, and sorted maps
+proved to be a great way to implement an especially flexible persistent priority queue.
+
+Connoisseurs of algorithms will note that this structure's peek operation is not O(1) as
+it would be if based upon a heap data structure, but I feel this is a small concession for
+the blend of persistence, priority reassignment, and priority-sorted seq, which can be
+quite expensive to achieve with a heap (I did actually try this for comparison). Furthermore,
+this peek's logarithmic behavior is quite good (on my computer I can do a million
+peeks at a priority map with a million items in 750ms). Also, consider that peek and pop
+usually follow one another, and even with a heap, pop is logarithmic. So the net combination
+of peek and pop is not much different between this versatile formulation of a priority map and
+a more limited heap-based one. In a nutshell, peek, although not O(1), is unlikely to be the
+bottleneck in your program.
+
+All in all, I hope you will find priority maps to be an easy-to-use and useful addition
+to Clojure's assortment of built-in maps (hash-map and sorted-map).
+"}
+ nextjournal.clerk.clojure.data.priority-map
+ (:refer-clojure :exclude [subseq rsubseq])
+ (:import clojure.lang.MapEntry java.util.Map clojure.lang.PersistentTreeMap))
+
+(declare pm-empty)
+
+(defmacro apply-keyfn [x]
+ `(if ~'keyfn (~'keyfn ~x) ~x))
+
+(defmacro ^:private compile-if [test then else]
+ (if (eval test)
+ then
+ else))
+
+;; We create a patched version of subseq and rsubseq from core, that works on ordinary sorted collections, as well as priority maps
+;; See https://dev.clojure.org/jira/browse/CLJ-428
+
+(defn mk-bound-fn
+ {:private true}
+ [^clojure.lang.Sorted sc test key]
+ (fn [e] (test (.. sc comparator (compare (. sc entryKey e) key)) 0)))
+
+(defn subseq
+ "sc must be a sorted collection, test(s) one of <, <=, > or
+ >=. Returns a seq of those entries with keys ek for
+ which (test (.. sc comparator (compare ek key)) 0) is true"
+ ([^clojure.lang.Sorted sc test key]
+ (let [include (mk-bound-fn sc test key)]
+ (if (#{> >=} test)
+ (when-let [[e :as s] (. sc seqFrom key true)]
+ (seq (drop-while #(not (include %)) s)))
+ (seq (take-while include (. sc seq true))))))
+ ([^clojure.lang.Sorted sc start-test start-key end-test end-key]
+ (when-let [[e :as s] (. sc seqFrom start-key true)]
+ (seq (take-while (mk-bound-fn sc end-test end-key)
+ (drop-while (complement (mk-bound-fn sc start-test start-key)) s))))))
+
+(defn rsubseq
+ "sc must be a sorted collection, test(s) one of <, <=, > or
+ >=. Returns a reverse seq of those entries with keys ek for
+ which (test (.. sc comparator (compare ek key)) 0) is true"
+ ([^clojure.lang.Sorted sc test key]
+ (let [include (mk-bound-fn sc test key)]
+ (if (#{< <=} test)
+ (when-let [[e :as s] (. sc seqFrom key false)]
+ (seq (drop-while #(not (include %)) s)))
+ (seq (take-while include (. sc seq false))))))
+ ([^clojure.lang.Sorted sc start-test start-key end-test end-key]
+ (when-let [[e :as s] (. sc seqFrom end-key false)]
+ (seq (take-while (mk-bound-fn sc start-test start-key)
+ (drop-while (complement (mk-bound-fn sc end-test end-key)) s))))))
+
+;; A Priority Map is comprised of a sorted map that maps priorities to hash sets of items
+;; with that priority (priority->set-of-items),
+;; as well as a hash map that maps items to priorities (item->priority)
+;; Priority maps may also have metadata
+;; Priority maps can also have a keyfn which is applied to the "priorities" found as values in
+;; the item->priority map to get the actual sortable priority keys used in priority->set-of-items.
+
+(deftype PersistentPriorityMap [priority->set-of-items item->priority _meta keyfn]
+ Object
+ (toString [this] (str (.seq this)))
+
+ clojure.lang.ILookup
+ ;; valAt gives (get pm key) and (get pm key not-found) behavior
+ (valAt [this item] (get item->priority item))
+ (valAt [this item not-found] (get item->priority item not-found))
+
+ clojure.lang.IPersistentMap
+ (count [this] (count item->priority))
+
+ (assoc [this item priority]
+ (let [current-priority (get item->priority item nil)]
+ (if current-priority
+ ;;Case 1 - item is already in priority map, so this is a reassignment
+ (if (= current-priority priority)
+ ;;Subcase 1 - no change in priority, do nothing
+ this
+ (let [priority-key (apply-keyfn priority)
+ current-priority-key (apply-keyfn current-priority)
+ item-set (get priority->set-of-items current-priority-key)]
+ (if (= (count item-set) 1)
+ ;;Subcase 2 - it was the only item of this priority
+ ;;so remove old priority entirely
+ ;;and conj item onto new priority's set
+ (PersistentPriorityMap.
+ (assoc (dissoc priority->set-of-items current-priority-key)
+ priority-key (conj (get priority->set-of-items priority-key #{}) item))
+ (assoc item->priority item priority)
+ (meta this)
+ keyfn)
+ ;;Subcase 3 - there were many items associated with the item's original priority,
+ ;;so remove it from the old set and conj it onto the new one.
+ (PersistentPriorityMap.
+ (assoc priority->set-of-items
+ current-priority-key (disj (get priority->set-of-items current-priority-key) item)
+ priority-key (conj (get priority->set-of-items priority-key #{}) item))
+ (assoc item->priority item priority)
+ (meta this)
+ keyfn))))
+ ;; Case 2: Item is new to the priority map, so just add it.
+ (let [priority-key (apply-keyfn priority)]
+ (PersistentPriorityMap.
+ (assoc priority->set-of-items
+ priority-key (conj (get priority->set-of-items priority-key #{}) item))
+ (assoc item->priority item priority)
+ (meta this)
+ keyfn)))))
+
+ (empty [this] (PersistentPriorityMap. (empty priority->set-of-items) {} _meta keyfn))
+
+ ;; cons defines conj behavior
+ (cons [this e]
+ (if (map? e)
+ (into this e)
+ (let [[item priority] e] (.assoc this item priority))))
+
+ ;; Like sorted maps, priority maps are equal to other maps provided
+ ;; their key-value pairs are the same.
+ (equiv [this o] (= item->priority o))
+ (hashCode [this] (.hashCode item->priority))
+ (equals [this o] (or (identical? this o) (.equals item->priority o)))
+
+ ;;containsKey implements (contains? pm k) behavior
+ (containsKey [this item] (contains? item->priority item))
+
+ (entryAt [this k]
+ (let [v (.valAt this k this)]
+ (when-not (identical? v this)
+ (MapEntry. k v))))
+
+ (seq [this]
+ (if keyfn
+ (seq (for [[priority item-set] priority->set-of-items, item item-set]
+ (MapEntry. item (item->priority item))))
+ (seq (for [[priority item-set] priority->set-of-items, item item-set]
+ (MapEntry. item priority)))))
+
+ ;;without implements (dissoc pm k) behavior
+ (without
+ [this item]
+ (let [priority (item->priority item ::not-found)]
+ (if (= priority ::not-found)
+ ;; If item is not in map, return the map unchanged.
+ this
+ (let [priority-key (apply-keyfn priority)
+ item-set (priority->set-of-items priority-key)]
+ (if (= (count item-set) 1)
+ ;;If it is the only item with this priority, remove that priority's set completely
+ (PersistentPriorityMap. (dissoc priority->set-of-items priority-key)
+ (dissoc item->priority item)
+ (meta this)
+ keyfn)
+ ;;Otherwise, just remove the item from the priority's set.
+ (PersistentPriorityMap.
+ (assoc priority->set-of-items priority-key (disj item-set item)),
+ (dissoc item->priority item)
+ (meta this)
+ keyfn))))))
+
+ clojure.lang.IHashEq
+ (hasheq [this]
+ (compile-if (resolve 'clojure.core/hash-unordered-coll)
+ (hash-unordered-coll this)
+ (.hashCode this)))
+
+ java.io.Serializable ;Serialization comes for free with the other things implemented
+ clojure.lang.MapEquivalence
+ Map ;Makes this compatible with java's map
+ (size [this] (count item->priority))
+ (isEmpty [this] (zero? (count item->priority)))
+ (containsValue [this v]
+ (if keyfn
+ (some (partial = v) (vals this)) ; no shortcut if there is a keyfn
+ (contains? priority->set-of-items v)))
+ (get [this k] (.valAt this k))
+ (put [this k v] (throw (UnsupportedOperationException.)))
+ (remove [this k] (throw (UnsupportedOperationException.)))
+ (putAll [this m] (throw (UnsupportedOperationException.)))
+ (clear [this] (throw (UnsupportedOperationException.)))
+ (keySet [this] (set (keys this)))
+ (values [this] (vals this))
+ (entrySet [this] (set this))
+
+ Iterable
+ (iterator [this] (clojure.lang.SeqIterator. (seq this)))
+
+ clojure.core.protocols/IKVReduce
+ (kv-reduce [this f init]
+ (if keyfn
+ (reduce-kv (fn [a k v]
+ (reduce (fn [a v] (f a v (item->priority v))) a v))
+ init priority->set-of-items)
+ (reduce-kv (fn [a k v]
+ (reduce (fn [a v] (f a v k)) a v))
+ init priority->set-of-items)))
+
+ clojure.lang.IPersistentStack
+ (peek [this]
+ (when-not (.isEmpty this)
+ (let [f (first priority->set-of-items)
+ item (first (val f))]
+ (if keyfn
+ (MapEntry. item (item->priority item))
+ (MapEntry. item (key f))))))
+
+ (pop [this]
+ (if (.isEmpty this) (throw (IllegalStateException. "Can't pop empty priority map"))
+ (let [f (first priority->set-of-items),
+ item-set (val f)
+ item (first item-set),
+ priority-key (key f)]
+ (if (= (count item-set) 1)
+ ;;If the first item is the only item with its priority, remove that priority's set completely
+ (PersistentPriorityMap.
+ (dissoc priority->set-of-items priority-key)
+ (dissoc item->priority item)
+ (meta this)
+ keyfn)
+ ;;Otherwise, just remove the item from the priority's set.
+ (PersistentPriorityMap.
+ (assoc priority->set-of-items priority-key (disj item-set item)),
+ (dissoc item->priority item)
+ (meta this)
+ keyfn)))))
+
+ clojure.lang.IFn
+ ;;makes priority map usable as a function
+ (invoke [this k] (.valAt this k))
+ (invoke [this k not-found] (.valAt this k not-found))
+
+ clojure.lang.IObj
+ ;;adds metadata support
+ (meta [this] _meta)
+ (withMeta [this m] (PersistentPriorityMap. priority->set-of-items item->priority m keyfn))
+
+ clojure.lang.Reversible
+ (rseq [this]
+ (if keyfn
+ (seq (for [[priority item-set] (rseq priority->set-of-items), item item-set]
+ (MapEntry. item (item->priority item))))
+ (seq (for [[priority item-set] (rseq priority->set-of-items), item item-set]
+ (MapEntry. item priority)))))
+
+ clojure.lang.Sorted
+ ;; These methods provide support for subseq and rsubseq
+ (comparator [this] (.comparator ^PersistentTreeMap priority->set-of-items))
+ (entryKey [this entry] (if keyfn (keyfn (val entry)) (val entry)))
+ (seqFrom [this k ascending]
+ (let [sets (if ascending (subseq priority->set-of-items >= k) (rsubseq priority->set-of-items <= k))]
+ (if keyfn
+ (seq (for [[priority item-set] sets, item item-set]
+ (MapEntry. item (item->priority item))))
+ (seq (for [[priority item-set] sets, item item-set]
+ (MapEntry. item priority))))))
+ (seq [this ascending]
+ (if ascending (seq this) (rseq this))))
+
+(def ^:private pm-empty (PersistentPriorityMap. (sorted-map) {} {} nil))
+(defn- pm-empty-by [comparator] (PersistentPriorityMap. (sorted-map-by comparator) {} {} nil))
+(defn- pm-empty-keyfn
+ ([keyfn] (PersistentPriorityMap. (sorted-map) {} {} keyfn))
+ ([keyfn comparator] (PersistentPriorityMap. (sorted-map-by comparator) {} {} keyfn)))
+
+
+;; The main way to build priority maps
+(defn priority-map
+ "Usage: (priority-map key val key val ...)
+ Returns a new priority map with optional supplied mappings.
+ (priority-map) returns an empty priority map."
+ [& keyvals]
+ {:pre [(even? (count keyvals))]}
+ (reduce conj pm-empty (partition 2 keyvals)))
+
+(defn priority-map-by
+ "Usage: (priority-map comparator key val key val ...)
+ Returns a new priority map with custom comparator and optional supplied mappings.
+ (priority-map-by comparator) yields an empty priority map with custom comparator."
+ [comparator & keyvals]
+ {:pre [(even? (count keyvals))]}
+ (reduce conj (pm-empty-by comparator) (partition 2 keyvals)))
+
+(defn priority-map-keyfn
+ "Usage: (priority-map-keyfn keyfn key val key val ...)
+ Returns a new priority map with custom keyfn and optional supplied mappings.
+ The priority is determined by comparing (keyfn val).
+ (priority-map-keyfn keyfn) yields an empty priority map with custom keyfn."
+ [keyfn & keyvals]
+ {:pre [(even? (count keyvals))]}
+ (reduce conj (pm-empty-keyfn keyfn) (partition 2 keyvals)))
+
+(defn priority-map-keyfn-by
+ "Usage: (priority-map-keyfn-by keyfn comparator key val key val ...)
+ Returns a new priority map with custom keyfn, custom comparator, and optional supplied mappings.
+ The priority is determined by comparing (keyfn val).
+ (priority-map-keyfn-by keyfn comparator) yields an empty priority map with custom keyfn and comparator."
+ [keyfn comparator & keyvals]
+ {:pre [(even? (count keyvals))]}
+ (reduce conj (pm-empty-keyfn keyfn comparator) (partition 2 keyvals)))
+
+(defn priority->set-of-items
+ "Takes a priority map p, and returns a sorted map from each priority
+ to the set of items with that priority in p"
+ [^PersistentPriorityMap p]
+ (.priority->set-of-items p))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj
new file mode 100644
index 000000000..81d7f629e
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm.clj
@@ -0,0 +1,673 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.jvm
+ "Analyzer for clojure code, extends tools.analyzer with JVM specific passes/forms"
+ (:refer-clojure :exclude [macroexpand-1 macroexpand])
+ (:require [clojure.tools.analyzer
+ :as ana
+ :refer [analyze analyze-in-env wrapping-meta analyze-fn-method]
+ :rename {analyze -analyze}]
+
+ [clojure.tools.analyzer
+ [utils :refer [ctx resolve-sym -source-info resolve-ns obj? dissoc-env butlast+last mmerge]]
+ [ast :refer [walk prewalk postwalk] :as ast]
+ [env :as env :refer [*env*]]
+ [passes :refer [schedule]]]
+
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer :all :as u :exclude [box specials]]
+
+ [clojure.tools.analyzer.passes
+ [source-info :refer [source-info]]
+ [trim :refer [trim]]
+ [elide-meta :refer [elide-meta elides]]
+ [warn-earmuff :refer [warn-earmuff]]
+ [uniquify :refer [uniquify-locals]]]
+
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm
+ [analyze-host-expr :refer [analyze-host-expr]]
+ [box :refer [box]]
+ [constant-lifter :refer [constant-lift]]
+ [classify-invoke :refer [classify-invoke]]
+ [validate :refer [validate]]
+ [infer-tag :refer [infer-tag]]
+ [validate-loop-locals :refer [validate-loop-locals]]
+ [warn-on-reflection :refer [warn-on-reflection]]
+ [emit-form :refer [emit-form]]]
+
+ [clojure.java.io :as io]
+ [clojure.tools.reader :as reader]
+ [clojure.tools.reader.reader-types :as readers]
+
+ [nextjournal.clerk.clojure.core.memoize :refer [memo-clear!]])
+ (:import (clojure.lang IObj RT Compiler Var)
+ java.net.URL))
+
+(set! *warn-on-reflection* true)
+
+(def ns-safe-macro
+ "Clojure macros that are known to not alter namespaces"
+ #{#'clojure.core/->
+ #'clojure.core/->>
+ #'clojure.core/..
+ #'clojure.core/and
+ #'clojure.core/as->
+ #'clojure.core/assert
+ #'clojure.core/case
+ #'clojure.core/cond
+ #'clojure.core/cond->
+ #'clojure.core/cond->>
+ #'clojure.core/condp
+ #'clojure.core/defn
+ #'clojure.core/defn-
+ #'clojure.core/delay
+ #'clojure.core/doseq
+ #'clojure.core/dosync
+ #'clojure.core/dotimes
+ #'clojure.core/doto
+ #'clojure.core/fn
+ #'clojure.core/for
+ #'clojure.core/future
+ #'clojure.core/if-let
+ #'clojure.core/if-not
+ #'clojure.core/lazy-seq
+ #'clojure.core/let
+ #'clojure.core/letfn
+ #'clojure.core/loop
+ #'clojure.core/or
+ #'clojure.core/reify
+ #'clojure.core/some->
+ #'clojure.core/some->>
+ #'clojure.core/sync
+ #'clojure.core/time
+ #'clojure.core/when
+ #'clojure.core/when-let
+ #'clojure.core/when-not
+ #'clojure.core/while
+ #'clojure.core/with-open
+ #'clojure.core/with-out-str
+ })
+
+(def specials
+ "Set of the special forms for clojure in the JVM"
+ (into ana/specials
+ '#{monitor-enter monitor-exit clojure.core/import* reify* deftype* case*}))
+
+(defn build-ns-map []
+ (into {} (mapv #(vector (ns-name %)
+ {:mappings (merge (ns-map %) {'in-ns #'clojure.core/in-ns
+ 'ns #'clojure.core/ns})
+ :aliases (reduce-kv (fn [a k v] (assoc a k (ns-name v)))
+ {} (ns-aliases %))
+ :ns (ns-name %)})
+ (all-ns))))
+
+(defn update-ns-map! []
+ ((get (env/deref-env) :update-ns-map! #())))
+
+(defn global-env []
+ (atom {:namespaces (build-ns-map)
+
+ :update-ns-map! (fn update-ns-map! []
+ (swap! *env* assoc-in [:namespaces] (build-ns-map)))}))
+
+(defn empty-env
+ "Returns an empty env map"
+ []
+ {:context :ctx/expr
+ :locals {}
+ :ns (ns-name *ns*)})
+
+(defn desugar-symbol [form env]
+ (let [sym-ns (namespace form)]
+ (if-let [target (and sym-ns
+ (not (resolve-ns (symbol sym-ns) env))
+ (maybe-class-literal sym-ns))] ;; Class/field
+ (let [opname (name form)
+ opname-sym (symbol opname)]
+ (if (and (= (count opname) 1)
+ (Character/isDigit ^Character (first opname)))
+ form ;; Array/
+ (cond
+ (= "new" opname)
+ `(fn
+ ([x#] (new ~(symbol sym-ns) x# d))
+ ;; TODO: analyze method and return properly expanded fn
+ )
+ (or (.startsWith opname ".")
+ (let [members (u/members target)]
+ ;; TODO: only pick non-methods!
+ (some #(when (and (= opname-sym (:name %))
+ (not (instance? clojure.reflect.Field %)))
+ %) members)))
+ `(fn
+ ([x#] (~form x#))
+ ;; TODO: analyze method and return properly expanded fn
+ )
+ :else
+ (with-meta (list '. target (symbol (str "-" opname))) ;; transform to (. Class -field)
+ (meta form)))))
+ form)))
+
+(defn desugar-host-expr [form env]
+ (let [[op & expr] form]
+ (if (symbol? op)
+ (let [opname (name op)
+ opns (namespace op)
+ opns-class ^Class (maybe-class-literal opns)]
+ (if-let [target (and opns
+ (not (resolve-ns (symbol opns) env))
+ (when-not (.startsWith opname ".")
+ opns-class))] ; (class/field ..)
+ (let [op (symbol opname)]
+ (if (= 'new op)
+ (with-meta (list* 'new (symbol opns) expr)
+ (meta form))
+ (with-meta (list '. target (if (zero? (count expr))
+ op
+ (list* op expr)))
+ (meta form))))
+
+ (cond
+ (.startsWith opname ".") ; (.foo bar ..)
+ (let [[target & args] expr
+ target (if opns-class
+ (with-meta (list 'do target)
+ {:tag (symbol (.getName opns-class))})
+ (if-let [target (maybe-class-literal target)]
+ (with-meta (list 'do target)
+ {:tag 'java.lang.Class})
+ target))
+ args (list* (symbol (subs opname 1)) args)]
+ (with-meta (list '. target (if (= 1 (count args)) ;; we don't know if (.foo bar) is
+ (first args) args)) ;; a method call or a field access
+ (meta form)))
+
+ (.endsWith opname ".") ;; (class. ..)
+ (with-meta (list* 'new (symbol (subs opname 0 (dec (count opname)))) expr)
+ (meta form))
+ :else form)))
+ form)))
+
+(defn macroexpand-1
+ "If form represents a macro form or an inlineable function,returns its expansion,
+ else returns form."
+ ([form] (macroexpand-1 form (empty-env)))
+ ([form env]
+ (env/ensure (global-env)
+ (cond
+
+ (seq? form)
+ (let [[op & args] form]
+ (if (specials op)
+ form
+ (let [v (resolve-sym op env)
+ m (meta v)
+ local? (-> env :locals (get op))
+ macro? (and (not local?) (:macro m)) ;; locals shadow macros
+ inline-arities-f (:inline-arities m)
+ inline? (and (not local?)
+ (or (not inline-arities-f)
+ (inline-arities-f (count args)))
+ (:inline m))
+ t (:tag m)]
+ (cond
+
+ macro?
+ (let [res (apply v form (:locals env) (rest form))] ; (m &form &env & args)
+ (when-not (ns-safe-macro v)
+ (update-ns-map!))
+ (if (obj? res)
+ (vary-meta res merge (meta form))
+ res))
+
+ inline?
+ (let [res (apply inline? args)]
+ (update-ns-map!)
+ (if (obj? res)
+ (vary-meta res merge
+ (and t {:tag t})
+ (meta form))
+ res))
+
+ :else
+ (desugar-host-expr form env)))))
+
+ (symbol? form)
+ (desugar-symbol form env)
+
+ :else
+ form))))
+
+(defn qualify-arglists [arglists]
+ (vary-meta arglists merge
+ (when-let [t (:tag (meta arglists))]
+ {:tag (if (or (string? t)
+ (u/specials (str t))
+ (u/special-arrays (str t)))
+ t
+ (if-let [c (maybe-class t)]
+ (let [new-t (-> c .getName symbol)]
+ (if (= new-t t)
+ t
+ (with-meta new-t {::qualified? true})))
+ t))})))
+
+(defn create-var
+ "Creates a Var for sym and returns it.
+ The Var gets interned in the env namespace."
+ [sym {:keys [ns]}]
+ (let [v (get-in (env/deref-env) [:namespaces ns :mappings (symbol (name sym))])]
+ (if (and v (or (class? v)
+ (= ns (ns-name (.ns ^Var v) ))))
+ v
+ (let [meta (dissoc (meta sym) :inline :inline-arities :macro)
+ meta (if-let [arglists (:arglists meta)]
+ (assoc meta :arglists (qualify-arglists arglists))
+ meta)]
+ (intern ns (with-meta sym meta))))))
+
+(defn parse-monitor-enter
+ [[_ target :as form] env]
+ (when-not (= 2 (count form))
+ (throw (ex-info (str "Wrong number of args to monitor-enter, had: " (dec (count form)))
+ (merge {:form form}
+ (-source-info form env)))))
+ {:op :monitor-enter
+ :env env
+ :form form
+ :target (-analyze target (ctx env :ctx/expr))
+ :children [:target]})
+
+(defn parse-monitor-exit
+ [[_ target :as form] env]
+ (when-not (= 2 (count form))
+ (throw (ex-info (str "Wrong number of args to monitor-exit, had: " (dec (count form)))
+ (merge {:form form}
+ (-source-info form env)))))
+ {:op :monitor-exit
+ :env env
+ :form form
+ :target (-analyze target (ctx env :ctx/expr))
+ :children [:target]})
+
+(defn parse-import*
+ [[_ class :as form] env]
+ (when-not (= 2 (count form))
+ (throw (ex-info (str "Wrong number of args to import*, had: " (dec (count form)))
+ (merge {:form form}
+ (-source-info form env)))))
+ {:op :import
+ :env env
+ :form form
+ :class class})
+
+(defn analyze-method-impls
+ [[method [this & params :as args] & body :as form] env]
+ (when-let [error-msg (cond
+ (not (symbol? method))
+ (str "Method method must be a symbol, had: " (class method))
+ (not (vector? args))
+ (str "Parameter listing should be a vector, had: " (class args))
+ (not (first args))
+ (str "Must supply at least one argument for 'this' in: " method))]
+ (throw (ex-info error-msg
+ (merge {:form form
+ :in (:this env)
+ :method method
+ :args args}
+ (-source-info form env)))))
+ (let [meth (cons (vec params) body) ;; this is an implicit arg
+ this-expr {:name this
+ :env env
+ :form this
+ :op :binding
+ :o-tag (:this env)
+ :tag (:this env)
+ :local :this}
+ env (assoc-in (dissoc env :this) [:locals this] (dissoc-env this-expr))
+ method-expr (analyze-fn-method meth env)]
+ (assoc (dissoc method-expr :variadic?)
+ :op :method
+ :form form
+ :this this-expr
+ :name (symbol (name method))
+ :children (into [:this] (:children method-expr)))))
+
+;; HACK
+(defn -deftype [name class-name args interfaces]
+
+ (doseq [arg [class-name name]]
+ (memo-clear! members* [arg])
+ (memo-clear! members* [(str arg)]))
+
+ (let [interfaces (mapv #(symbol (.getName ^Class %)) interfaces)]
+ (eval (list `let []
+ (list 'deftype* name class-name args :implements interfaces)
+ (list `import class-name)))))
+
+(defn parse-reify*
+ [[_ interfaces & methods :as form] env]
+ (let [interfaces (conj (disj (set (mapv maybe-class interfaces)) Object)
+ IObj)
+ name (gensym "reify__")
+ class-name (symbol (str (namespace-munge *ns*) "$" name))
+ menv (assoc env :this class-name)
+ methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces)
+ methods)]
+
+ (-deftype name class-name [] interfaces)
+
+ (wrapping-meta
+ {:op :reify
+ :env env
+ :form form
+ :class-name class-name
+ :methods methods
+ :interfaces interfaces
+ :children [:methods]})))
+
+(defn parse-opts+methods [methods]
+ (loop [opts {} methods methods]
+ (if (keyword? (first methods))
+ (recur (assoc opts (first methods) (second methods)) (nnext methods))
+ [opts methods])))
+
+(defn parse-deftype*
+ [[_ name class-name fields _ interfaces & methods :as form] env]
+ (let [interfaces (disj (set (mapv maybe-class interfaces)) Object)
+ fields-expr (mapv (fn [name]
+ {:env env
+ :form name
+ :name name
+ :mutable (let [m (meta name)]
+ (or (and (:unsynchronized-mutable m)
+ :unsynchronized-mutable)
+ (and (:volatile-mutable m)
+ :volatile-mutable)))
+ :local :field
+ :op :binding})
+ fields)
+ menv (assoc env
+ :context :ctx/expr
+ :locals (zipmap fields (map dissoc-env fields-expr))
+ :this class-name)
+ [opts methods] (parse-opts+methods methods)
+ methods (mapv #(assoc (analyze-method-impls % menv) :interfaces interfaces)
+ methods)]
+
+ (-deftype name class-name fields interfaces)
+
+ {:op :deftype
+ :env env
+ :form form
+ :name name
+ :class-name class-name ;; internal, don't use as a Class
+ :fields fields-expr
+ :methods methods
+ :interfaces interfaces
+ :children [:fields :methods]}))
+
+(defn parse-case*
+ [[_ expr shift mask default case-map switch-type test-type & [skip-check?] :as form] env]
+ (let [[low high] ((juxt first last) (keys case-map)) ;;case-map is a sorted-map
+ e (ctx env :ctx/expr)
+ test-expr (-analyze expr e)
+ [tests thens] (reduce (fn [[te th] [min-hash [test then]]]
+ (let [test-expr (ana/analyze-const test e)
+ then-expr (-analyze then env)]
+ [(conj te {:op :case-test
+ :form test
+ :env e
+ :hash min-hash
+ :test test-expr
+ :children [:test]})
+ (conj th {:op :case-then
+ :form then
+ :env env
+ :hash min-hash
+ :then then-expr
+ :children [:then]})]))
+ [[] []] case-map)
+ default-expr (-analyze default env)]
+ {:op :case
+ :form form
+ :env env
+ :test (assoc test-expr :case-test true)
+ :default default-expr
+ :tests tests
+ :thens thens
+ :shift shift
+ :mask mask
+ :low low
+ :high high
+ :switch-type switch-type
+ :test-type test-type
+ :skip-check? skip-check?
+ :children [:test :tests :thens :default]}))
+
+(defn parse
+ "Extension to tools.analyzer/-parse for JVM special forms"
+ [form env]
+ ((case (first form)
+ monitor-enter parse-monitor-enter
+ monitor-exit parse-monitor-exit
+ clojure.core/import* parse-import*
+ reify* parse-reify*
+ deftype* parse-deftype*
+ case* parse-case*
+ #_:else ana/-parse)
+ form env))
+
+(def default-passes
+ "Set of passes that will be run by default on the AST by #'run-passes"
+ #{#'warn-on-reflection
+ #'warn-earmuff
+
+ #'uniquify-locals
+
+ #'source-info
+ #'elide-meta
+ #'constant-lift
+
+ #'trim
+
+ #'box
+
+ #'analyze-host-expr
+ #'validate-loop-locals
+ #'validate
+ #'infer-tag
+
+ #'classify-invoke})
+
+(def scheduled-default-passes
+ (schedule default-passes))
+
+(defn ^:dynamic run-passes
+ "Function that will be invoked on the AST tree immediately after it has been constructed,
+ by default runs the passes declared in #'default-passes, should be rebound if a different
+ set of passes is required.
+
+ Use #'clojure.tools.analyzer.passes/schedule to get a function from a set of passes that
+ run-passes can be bound to."
+ [ast]
+ (scheduled-default-passes ast))
+
+(def default-passes-opts
+ "Default :passes-opts for `analyze`"
+ {:collect/what #{:constants :callsites}
+ :collect/where #{:deftype :reify :fn}
+ :collect/top-level? false
+ :collect-closed-overs/where #{:deftype :reify :fn :loop :try}
+ :collect-closed-overs/top-level? false})
+
+(defn analyze
+ "Analyzes a clojure form using tools.analyzer augmented with the JVM specific special ops
+ and returns its AST, after running #'run-passes on it.
+
+ If no configuration option is provides, analyze will setup tools.analyzer using the extension
+ points declared in this namespace.
+
+ If provided, opts should be a map of options to analyze, currently the only valid
+ options are :bindings and :passes-opts (if not provided, :passes-opts defaults to the
+ value of `default-passes-opts`).
+ If provided, :bindings should be a map of Var->value pairs that will be merged into the
+ default bindings for tools.analyzer, useful to provide custom extension points.
+ If provided, :passes-opts should be a map of pass-name-kw->pass-config-map pairs that
+ can be used to configure the behaviour of each pass.
+
+ E.g.
+ (analyze form env {:bindings {#'ana/macroexpand-1 my-mexpand-1}})"
+ ([form] (analyze form (empty-env) {}))
+ ([form env] (analyze form env {}))
+ ([form env opts]
+ (with-bindings (merge {Compiler/LOADER (RT/makeClassLoader)
+ #'ana/macroexpand-1 macroexpand-1
+ #'ana/create-var create-var
+ #'ana/parse parse
+ #'ana/var? var?
+ #'elides (merge {:fn #{:line :column :end-line :end-column :file :source}
+ :reify #{:line :column :end-line :end-column :file :source}}
+ elides)
+ #'*ns* (the-ns (:ns env))}
+ (:bindings opts))
+ (env/ensure (global-env)
+ (doto (env/with-env (mmerge (env/deref-env)
+ {:passes-opts (get opts :passes-opts default-passes-opts)})
+ (run-passes (-analyze form env)))
+ (do (update-ns-map!)))))))
+
+(deftype ExceptionThrown [e ast])
+
+(defn ^:private throw! [e]
+ (throw (.e ^ExceptionThrown e)))
+
+(defn analyze+eval
+ "Like analyze but evals the form after the analysis and attaches the
+ returned value in the :result field of the AST node.
+
+ If evaluating the form will cause an exception to be thrown, the exception
+ will be caught and wrapped in an ExceptionThrown object, containing the
+ exception in the `e` field and the AST in the `ast` field.
+
+ The ExceptionThrown object is then passed to `handle-evaluation-exception`,
+ which by defaults throws the original exception, but can be used to provide
+ a replacement return value for the evaluation of the AST.
+
+ Unrolls `do` forms to handle the Gilardi scenario.
+
+ Useful when analyzing whole files/namespaces."
+ ([form] (analyze+eval form (empty-env) {}))
+ ([form env] (analyze+eval form env {}))
+ ([form env {:keys [handle-evaluation-exception]
+ :or {handle-evaluation-exception throw!}
+ :as opts}]
+ (env/ensure (global-env)
+ (update-ns-map!)
+ (let [env (merge env (-source-info form env))
+ [mform raw-forms] (with-bindings {Compiler/LOADER (RT/makeClassLoader)
+ #'*ns* (the-ns (:ns env))
+ #'ana/macroexpand-1 (get-in opts [:bindings #'ana/macroexpand-1] macroexpand-1)}
+ (loop [form form raw-forms []]
+ (let [mform (ana/macroexpand-1 form env)]
+ (if (= mform form)
+ [mform (seq raw-forms)]
+ (recur mform (conj raw-forms
+ (if-let [[op & r] (and (seq? form) form)]
+ (if (or (u/macro? op env)
+ (u/inline? op r env))
+ (vary-meta form assoc ::ana/resolved-op (resolve-sym op env))
+ form)
+ form)))))))]
+ (if (and (seq? mform) (= 'do (first mform)) (next mform))
+ ;; handle the Gilardi scenario
+ (let [[statements ret] (butlast+last (rest mform))
+ statements-expr (mapv (fn [s] (analyze+eval s (-> env
+ (ctx :ctx/statement)
+ (assoc :ns (ns-name *ns*)))
+ opts))
+ statements)
+ ret-expr (analyze+eval ret (assoc env :ns (ns-name *ns*)) opts)]
+ {:op :do
+ :top-level true
+ :form mform
+ :statements statements-expr
+ :ret ret-expr
+ :children [:statements :ret]
+ :env env
+ :result (:result ret-expr)
+ :raw-forms raw-forms})
+ (let [a (analyze mform env opts)
+ frm (emit-form a)
+ result (try (eval frm) ;; eval the emitted form rather than directly the form to avoid double macroexpansion
+ (catch Exception e
+ (handle-evaluation-exception (ExceptionThrown. e a))))]
+ (merge a {:result result
+ :raw-forms raw-forms})))))))
+
+(defn analyze-ns
+ "Analyzes a whole namespace, returns a vector of the ASTs for all the
+ top-level ASTs of that namespace.
+ Evaluates all the forms."
+ ([ns] (analyze-ns ns (empty-env)))
+ ([ns env] (analyze-ns ns env {}))
+ ([ns env opts]
+ (env/ensure (global-env)
+ (let [res ^URL (ns-url ns)]
+ (assert res (str "Can't find " ns " in classpath"))
+ (let [filename (str res)
+ path (.getPath res)]
+ (when-not (get-in (env/deref-env) [::analyzed-clj path])
+ (binding [*ns* *ns*
+ *file* filename]
+ (with-open [rdr (io/reader res)]
+ (let [pbr (readers/indexing-push-back-reader
+ (java.io.PushbackReader. rdr) 1 filename)
+ eof (Object.)
+ read-opts {:eof eof :features #{:clj :t.a.jvm}}
+ read-opts (if (.endsWith filename "cljc")
+ (assoc read-opts :read-cond :allow)
+ read-opts)]
+ (loop []
+ (let [form (reader/read read-opts pbr)]
+ (when-not (identical? form eof)
+ (swap! *env* update-in [::analyzed-clj path]
+ (fnil conj [])
+ (analyze+eval form (assoc env :ns (ns-name *ns*)) opts))
+ (recur))))))))
+ (get-in @*env* [::analyzed-clj path]))))))
+
+(defn macroexpand-all
+ "Like clojure.walk/macroexpand-all but correctly handles lexical scope"
+ ([form] (macroexpand-all form (empty-env) {}))
+ ([form env] (macroexpand-all form env {}))
+ ([form env opts]
+ (binding [run-passes emit-form]
+ (analyze form env opts))))
+
+(comment
+ (analyze+eval '(String/.length "foo"))
+ (analyze+eval 'String/.length)
+ (with-bindings {#'ana/macroexpand-1 macroexpand-1
+ #'ana/parse parse}
+ (env/ensure (global-env)
+ (-analyze '(fn [x]
+ (String/.length x)) (empty-env))))
+
+ (macroexpand-1 'String/.length)
+ (macroexpand-1 'Integer/parseInt)
+ (clojure.core/macroexpand-1 'Integer/parseInt)
+ (macroexpand-1 'Long/parseLong)
+ (eval (macroexpand-1 '(fn [x]
+ (String/.length x))))
+
+ (macroexpand-1 'clojure.lang.Compiler/LOADER)
+ (macroexpand-1 '(String/new "foo"))
+
+ )
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj
new file mode 100644
index 000000000..eb7ac83d8
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/jvm/utils.clj
@@ -0,0 +1,399 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.jvm.utils
+ (:require [clojure.tools.analyzer.utils :as u]
+ [clojure.tools.analyzer.env :as env]
+ [clojure.reflect :as reflect]
+ [clojure.string :as s]
+ [nextjournal.clerk.clojure.core.memoize :refer [lru]]
+ [clojure.java.io :as io])
+ (:import (clojure.lang RT Symbol Var)
+ org.objectweb.asm.Type))
+
+(set! *warn-on-reflection* true)
+
+(defn ^:private type-reflect
+ [typeref & options]
+ (apply reflect/type-reflect typeref
+ :reflector (reflect/->JavaReflector (RT/baseLoader))
+ options))
+
+(defn macro? [sym env]
+ (when-let [v (u/resolve-sym sym env)]
+ (and (not (-> env :locals (get sym)))
+ (u/macro? v)
+ v)))
+
+(defn inline? [sym args env]
+ (when-let [v (u/resolve-sym sym env)]
+ (let [inline-arities-f (:inline-arities (meta v))]
+ (and (not (-> env :locals (get sym)))
+ (or (not inline-arities-f)
+ (inline-arities-f (count args)))
+ (:inline (meta v))))))
+
+(defn specials [c]
+ (case c
+ "byte" Byte/TYPE
+ "boolean" Boolean/TYPE
+ "char" Character/TYPE
+ "int" Integer/TYPE
+ "long" Long/TYPE
+ "float" Float/TYPE
+ "double" Double/TYPE
+ "short" Short/TYPE
+ "void" Void/TYPE
+ "object" Object
+ nil))
+
+(defn special-arrays [c]
+ (case c
+ "bytes" (Class/forName "[B")
+ "booleans" (Class/forName "[Z")
+ "chars" (Class/forName "[C")
+ "ints" (Class/forName "[I")
+ "longs" (Class/forName "[J")
+ "floats" (Class/forName "[F")
+ "doubles" (Class/forName "[D")
+ "shorts" (Class/forName "[S")
+ "objects" (Class/forName "[Ljava.lang.Object;")
+ nil))
+
+(defmulti ^Class maybe-class
+ "Takes a Symbol, String or Class and tires to resolve to a matching Class"
+ class)
+
+(defn array-class
+ ([element-type] (array-class 1 element-type))
+ ([n element-type]
+ (RT/classForName
+ (str (apply str (repeat n"["))
+ (-> element-type
+ maybe-class
+ Type/getType
+ .getDescriptor
+ (.replace \/ \.))))))
+
+(defn maybe-class-from-string [^String s]
+ (or (when-let [maybe-class (and (neg? (.indexOf s "."))
+ (not= \[ (first s))
+ (if env/*env*
+ (u/resolve-sym (symbol s) {:ns (ns-name *ns*)})
+ ((ns-map *ns*) (symbol s))))]
+ (when (class? maybe-class) maybe-class))
+ (try (RT/classForName s)
+ (catch ClassNotFoundException _))))
+
+(defmethod maybe-class :default [_] nil)
+(defmethod maybe-class Class [c] c)
+(defmethod maybe-class String [s]
+ (maybe-class (symbol s)))
+
+(defn maybe-array-class-sym [x]
+ (let [sname (name x)]
+ (if-let [c (and (= (count sname) 1)
+ (Character/isDigit (char (first sname)))
+ (namespace x))]
+ (when-let [c (or (specials c)
+ (maybe-class-from-string c))]
+ (array-class (Integer/parseInt sname) c)))))
+
+(defmethod maybe-class Symbol [sym]
+ (let [sname (name sym)
+ snamec (count sname)]
+ (or (maybe-array-class-sym sym)
+ (when-not (namespace sym)
+ (if-let [base-type (and (.endsWith sname "<>")
+ (maybe-class (subs sname 0 (- snamec 2))))]
+ ;; TODO: we're leaking into the syntax
+ (array-class base-type)
+ (if-let [ret (or (specials sname)
+ (special-arrays sname))]
+ ret
+ (maybe-class-from-string sname)))))))
+
+(defn maybe-class-literal [x]
+ (cond
+ (class? x) x
+ (symbol? x) (or (maybe-array-class-sym x)
+ (and (not (namespace x))
+ (maybe-class-from-string (name x))))
+ (string? x) (maybe-class-from-string x)))
+
+(def primitive?
+ "Returns non-nil if the argument represents a primitive Class other than Void"
+ #{Double/TYPE Character/TYPE Byte/TYPE Boolean/TYPE
+ Short/TYPE Float/TYPE Long/TYPE Integer/TYPE})
+
+(def ^:private convertible-primitives
+ "If the argument is a primitive Class, returns a set of Classes
+ to which the primitive Class can be casted"
+ {Integer/TYPE #{Integer Long/TYPE Long Short/TYPE Byte/TYPE Object Number}
+ Float/TYPE #{Float Double/TYPE Object Number}
+ Double/TYPE #{Double Float/TYPE Object Number}
+ Long/TYPE #{Long Integer/TYPE Short/TYPE Byte/TYPE Object Number}
+ Character/TYPE #{Character Object}
+ Short/TYPE #{Short Object Number}
+ Byte/TYPE #{Byte Object Number}
+ Boolean/TYPE #{Boolean Object}
+ Void/TYPE #{Void}})
+
+(defn ^Class box
+ "If the argument is a primitive Class, returns its boxed equivalent,
+ otherwise returns the argument"
+ [c]
+ ({Integer/TYPE Integer
+ Float/TYPE Float
+ Double/TYPE Double
+ Long/TYPE Long
+ Character/TYPE Character
+ Short/TYPE Short
+ Byte/TYPE Byte
+ Boolean/TYPE Boolean
+ Void/TYPE Void}
+ c c))
+
+(defn ^Class unbox
+ "If the argument is a Class with a primitive equivalent, returns that,
+ otherwise returns the argument"
+ [c]
+ ({Integer Integer/TYPE,
+ Long Long/TYPE,
+ Float Float/TYPE,
+ Short Short/TYPE,
+ Boolean Boolean/TYPE,
+ Byte Byte/TYPE,
+ Character Character/TYPE,
+ Double Double/TYPE,
+ Void Void/TYPE}
+ c c))
+
+(defn numeric?
+ "Returns true if the given class is numeric"
+ [c]
+ (when c
+ (.isAssignableFrom Number (box c))))
+
+(defn subsumes?
+ "Returns true if c2 is subsumed by c1"
+ [c1 c2]
+ (let [c1 (maybe-class c1)
+ c2 (maybe-class c2)]
+ (and (not= c1 c2)
+ (or (and (not (primitive? c1))
+ (primitive? c2))
+ (.isAssignableFrom c2 c1)))))
+
+(defn convertible?
+ "Returns true if it's possible to convert from c1 to c2"
+ [c1 c2]
+ (let [c1 (maybe-class c1)
+ c2 (maybe-class c2)]
+ (if (nil? c1)
+ (not (primitive? c2))
+ (or
+ (= c1 c2)
+ (.isAssignableFrom c2 c1)
+ (and (primitive? c2)
+ ((convertible-primitives c2) c1))
+ (and (primitive? c1)
+ (.isAssignableFrom (box c1) c2))))))
+
+(def wider-than
+ "If the argument is a numeric primitive Class, returns a set of primitive Classes
+ that are narrower than the given one"
+ {Long/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE}
+ Integer/TYPE #{Short/TYPE Byte/TYPE}
+ Float/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE}
+ Double/TYPE #{Integer/TYPE Short/TYPE Byte/TYPE Long/TYPE Float/TYPE}
+ Short/TYPE #{Byte/TYPE}
+ Byte/TYPE #{}})
+
+(defn wider-primitive
+ "Given two numeric primitive Classes, returns the wider one"
+ [from to]
+ (if ((wider-than from) to)
+ from
+ to))
+
+(defn wider-tag*
+ "Given two Classes returns the wider one"
+ [from to]
+ (if (not= from to)
+ (if (primitive? from)
+ (if (primitive? to)
+ (wider-primitive from to)
+ (or (and (numeric? from)
+ (numeric? to)
+ to)
+ ((convertible-primitives from) to)))
+ (if (primitive? to)
+ (or (and (numeric? from)
+ (numeric? to)
+ from)
+ ((convertible-primitives to) from))
+ (if (convertible? from to)
+ to
+ (when (convertible? to from)
+ from))))
+ from))
+
+(defn wider-tag
+ "Given a collection of Classes returns the wider one"
+ [tags]
+ (let [tags* (filter identity tags)
+ wider (loop [wider (first tags*) tags* (rest tags*)]
+ (if (seq tags*)
+ (if-let [t (wider-tag* wider (first tags*))]
+ (recur t (rest tags*)))
+ wider))]
+ (when (or (= tags* tags)
+ (not (primitive? wider)))
+ wider)))
+
+(defn name-matches?
+ [member]
+ (let [member-name (str member)
+ i (.lastIndexOf member-name ".")
+ member-name* (when (pos? i)
+ (str (s/replace (subs member-name 0 i) "-" "_") (subs member-name i)))
+ member-name** (s/replace member-name "-" "_")
+ member-name*** (munge member-name)]
+ (fn [name]
+ (let [name (str name)]
+ (or (= member-name name)
+ (= member-name* name)
+ (= member-name** name)
+ (= member-name*** name))))))
+
+(def object-members
+ (:members (type-reflect Object)))
+
+(def members*
+ (lru (fn members*
+ ([class]
+ (into object-members
+ (remove (fn [{:keys [flags]}]
+ (not-any? #{:public :protected} flags))
+ (-> class
+ maybe-class
+ ^Class (box)
+ .getName
+ symbol
+ (type-reflect :ancestors true)
+ :members)))))))
+
+(defn members
+ ([class] (members* class))
+ ([class member]
+ (when-let [members (filter #((name-matches? member) (:name %))
+ (members* class))]
+ members)))
+
+(defn static-members [class f]
+ (when-let [members (members class f)]
+ (when-let [statics (filter (comp :static :flags) members)]
+ statics)))
+
+(defn instance-members [class f]
+ (when-let [members (members class f)]
+ (when-let [i-members (remove (comp :static :flags) members)]
+ i-members)))
+
+(defn static-methods [class method argc]
+ (filter #(= argc (count (:parameter-types %)))
+ (filter :return-type (static-members class method))))
+
+(defn instance-methods [class method argc]
+ (filter #(= argc (count (:parameter-types %)))
+ (filter :return-type (instance-members class method))))
+
+(defn static-field [class f]
+ (when-let [statics (static-members class f)]
+ (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types)
+ (comp nil? :return-type))
+ statics)]
+ member)))
+
+(defn instance-field [class f]
+ (when-let [i-members (instance-members class f)]
+ (when-let [[member] (filter (every-pred (comp nil? seq :parameter-types)
+ (comp nil? :return-type))
+ i-members)]
+ member)))
+
+(defn static-method [class method]
+ (first (static-methods class method 0)))
+
+(defn instance-method [class method]
+ (first (instance-methods class method 0)))
+
+(defn prim-or-obj
+ "If the given Class is a primitive, returns that Class, otherwise returns Object"
+ [tag]
+ (if (and tag (primitive? tag))
+ tag
+ java.lang.Object))
+
+(defn prim-interface [tags]
+ (when (some primitive? tags)
+ (let [sig (apply str (mapv #(.toUpperCase (subs (.getSimpleName ^Class %) 0 1)) tags))]
+ (maybe-class (str "clojure.lang.IFn$" sig)))))
+
+(defn tag-match? [arg-tags meth]
+ (every? identity (map convertible? arg-tags (:parameter-types meth))))
+
+(defn try-best-match
+ "Given a vector of arg tags and a collection of methods, tries to return the
+ subset of methods that match best the given tags"
+ [tags methods]
+ (let [o-tags (mapv #(or (maybe-class %) Object) tags)]
+ (if-let [methods (or (seq (filter
+ #(= o-tags (mapv maybe-class (:parameter-types %))) methods))
+ (seq (filter #(tag-match? tags %) methods)))]
+ (reduce (fn [[prev & _ :as p] next]
+ (let [prev-params (mapv maybe-class (:parameter-types prev))
+ next-params (mapv maybe-class (:parameter-types next))
+ prev-ret (maybe-class (:return-type prev))
+ next-ret (maybe-class (:return-type next))
+ prev-decl (maybe-class (:declaring-class prev))
+ next-decl (maybe-class (:declaring-class next))]
+ (cond
+ (not prev)
+ [next]
+ (= prev-params next-params)
+ (cond
+ (= prev-ret next-ret)
+ (cond
+ (.isAssignableFrom prev-decl next-decl)
+ [next]
+ (.isAssignableFrom next-decl prev-decl)
+ p
+ :else
+ (conj p next))
+ (.isAssignableFrom prev-ret next-ret)
+ [next]
+ (.isAssignableFrom next-ret prev-ret)
+ p
+ :else
+ (conj p next))
+ (and (some true? (map subsumes? next-params prev-params))
+ (not-any? true? (map subsumes? prev-params next-params)))
+ [next]
+ :else
+ (conj p next)))) [] methods)
+ methods)))
+
+(defn ns->relpath [s]
+ (-> s str (s/replace \. \/) (s/replace \- \_) (str ".clj")))
+
+(defn ns-url [ns]
+ (let [f (ns->relpath ns)]
+ (or (io/resource f)
+ (io/resource (str f "c")))))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj
new file mode 100644
index 000000000..ccd982115
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/analyze_host_expr.clj
@@ -0,0 +1,198 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.analyze-host-expr
+ (:require [clojure.tools.analyzer :as ana]
+ [clojure.tools.analyzer.utils :refer [ctx source-info merge']]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer :all]))
+
+(defn maybe-static-field [[_ class sym]]
+ (when-let [{:keys [flags type name]} (static-field class sym)]
+ {:op :static-field
+ :assignable? (not (:final flags))
+ :class class
+ :field name
+ :o-tag type
+ :tag type}))
+
+(defn maybe-static-method [[_ class sym]]
+ (when-let [{:keys [name return-type]} (static-method class sym)]
+ {:op :static-call
+ :tag return-type
+ :o-tag return-type
+ :class class
+ :method name}))
+
+(defn maybe-instance-method [target-expr class sym]
+ (when-let [{:keys [return-type]} (instance-method class sym)]
+ {:op :instance-call
+ :tag return-type
+ :o-tag return-type
+ :instance target-expr
+ :class class
+ :method sym
+ :children [:instance]}))
+
+(defn maybe-instance-field [target-expr class sym]
+ (when-let [{:keys [flags name type]} (instance-field class sym)]
+ {:op :instance-field
+ :assignable? (not (:final flags))
+ :class class
+ :instance target-expr
+ :field name
+ :tag type
+ :o-tag type
+ :children [:instance]}))
+
+(defn analyze-host-call
+ [target-type method args target-expr class env]
+ (let [op (case target-type
+ :static :static-call
+ :instance :instance-call)]
+ (merge
+ {:op op
+ :method method
+ :args args}
+ (case target-type
+ :static {:class class
+ :children [:args]}
+ :instance {:instance target-expr
+ :class (maybe-class (:tag target-expr))
+ :children [:instance :args]}))))
+
+(defn analyze-host-field
+ [target-type field target-expr class env]
+ (if class
+ (case target-type
+ :static (or (maybe-static-field (list '. class field))
+ (throw (ex-info (str "Cannot find field "
+ field " for class " class)
+ (merge {:class class
+ :field field}
+ (source-info env)))))
+ :instance (or (maybe-instance-field target-expr class field)
+ {:op :host-interop
+ :target (dissoc target-expr :tag :validated?)
+ :m-or-f field
+ :assignable? true
+ :children [:target]}
+ (when (:literal? target-expr)
+ (throw (ex-info (str "Cannot find field "
+ field " for class " class)
+ (merge {:instance (dissoc target-expr :env)
+ :field field}
+ (source-info env)))))))
+ {:op :host-interop
+ :target target-expr
+ :m-or-f field
+ :assignable? true
+ :children [:target]}))
+
+(defn -analyze-host-expr
+ [target-type m-or-f target-expr class env]
+ (let [target-class (-> target-expr :tag)
+ [field method] (if class
+ [(maybe-static-field (list '. class m-or-f))
+ (maybe-static-method (list '. class m-or-f))]
+ (when target-class
+ [(maybe-instance-field target-expr target-class m-or-f)
+ (maybe-instance-method target-expr target-class m-or-f)]))]
+ (cond
+
+ (not (or class target-class))
+ {:op :host-interop
+ :target target-expr
+ :m-or-f m-or-f
+ :assignable? true
+ :children [:target]}
+
+ method
+ method
+
+ field
+ field
+
+ class
+ (throw (ex-info (str "Cannot find field or no-arg method call "
+ m-or-f " for class " class)
+ (merge {:class class
+ :m-or-f m-or-f}
+ (source-info env))))
+
+ target-class
+ {:op :host-interop
+ :target (dissoc target-expr :tag :validated?)
+ :m-or-f m-or-f
+ :assignable? true
+ :children [:target]}
+
+ :else
+ (when (:literal? target-expr)
+ (throw (ex-info (str "Cannot find field or no-arg method call "
+ m-or-f " for class " target-class)
+ (merge {:instance (dissoc target-expr :env)
+ :m-or-f m-or-f}
+ (source-info env))))))))
+
+(defn analyze-host-expr
+ "Performing some reflection, transforms :host-interop/:host-call/:host-field
+ nodes in either: :static-field, :static-call, :instance-call, :instance-field
+ or :host-interop nodes, and a :var/:maybe-class/:maybe-host-form node in a
+ :const :class node, if necessary (class literals shadow Vars).
+
+ A :host-interop node represents either an instance-field or a no-arg instance-method. "
+ {:pass-info {:walk :post :depends #{}}}
+ [{:keys [op target form tag env class] :as ast}]
+ (case op
+ (:host-interop :host-call :host-field)
+ (let [target (if-let [the-class (and (= :local (:op target))
+ (maybe-class-literal (:form target)))]
+ (merge target
+ (assoc (ana/analyze-const the-class env :class)
+ :tag Class
+ :o-tag Class))
+ target)
+ class? (and (= :const (:op target))
+ (= :class (:type target))
+ (:form target))
+ target-type (if class? :static :instance)]
+ (merge' (dissoc ast :assignable? :target :args :children)
+ (case op
+
+ :host-call
+ (analyze-host-call target-type (:method ast)
+ (:args ast) target class? env)
+
+ :host-field
+ (analyze-host-field target-type (:field ast)
+ target (or class? (:tag target)) env)
+
+ :host-interop
+ (-analyze-host-expr target-type (:m-or-f ast)
+ target class? env))
+ (when tag
+ {:tag tag})))
+ :var
+ (if-let [the-class (and (not (namespace form))
+ (pos? (.indexOf (str form) "."))
+ (maybe-class-literal form))]
+ (assoc (ana/analyze-const the-class env :class) :form form)
+ ast)
+
+ :maybe-class
+ (if-let [the-class (maybe-class-literal class)]
+ (assoc (ana/analyze-const the-class env :class) :form form)
+ ast)
+
+ :maybe-host-form
+ (if-let [the-class (maybe-array-class-sym (symbol (str (:class ast))
+ (str (:field ast))))]
+ (assoc (ana/analyze-const the-class env :class) :form form)
+ ast)
+
+ ast))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj
new file mode 100644
index 000000000..1514710b0
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_branch.clj
@@ -0,0 +1,46 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-branch)
+
+(defmulti annotate-branch
+ "Adds :branch? to branch AST nodes (if/case), :test? to the test children
+ node of the branching op and :path? to the branching paths.
+
+ Example: {:op if :branch? true :test {:test? true ..} :then {:path? true ..} ..}"
+ {:pass-info {:walk :any :depends #{}}}
+ :op)
+
+(defmethod annotate-branch :if
+ [ast]
+ (-> ast
+ (assoc :branch? true)
+ (assoc-in [:test :test?] true)
+ (assoc-in [:then :path?] true)
+ (assoc-in [:else :path?] true)))
+
+(defmethod annotate-branch :fn-method
+ [ast]
+ (assoc ast :path? true))
+
+(defmethod annotate-branch :method
+ [ast]
+ (assoc ast :path? true))
+
+(defmethod annotate-branch :case
+ [ast]
+ (-> ast
+ (assoc :branch? true)
+ (assoc-in [:test :test?] true)
+ (assoc-in [:default :path?] true)))
+
+(defmethod annotate-branch :case-then
+ [ast]
+ (assoc ast :path? true))
+
+(defmethod annotate-branch :default [ast] ast)
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj
new file mode 100644
index 000000000..1aa145a07
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_host_info.clj
@@ -0,0 +1,109 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-host-info
+ (:require [clojure.tools.analyzer :as ana]
+ [clojure.tools.analyzer.ast :refer [prewalk]]
+ [clojure.tools.analyzer.passes
+ [cleanup :refer [cleanup]]
+ [elide-meta :refer [elide-meta]]]
+ [clojure.tools.analyzer.utils :refer [source-info]]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils
+ :refer [members name-matches? try-best-match]
+ :as u]))
+
+(defn annotate-host-info
+ "Adds a :methods key to reify/deftype :methods info representing
+ the reflected informations for the required methods, replaces
+ (catch :default ..) forms with (catch Throwable ..)"
+ {:pass-info {:walk :pre :depends #{} :after #{#'elide-meta}}}
+ [{:keys [op methods interfaces class env] :as ast}]
+ (case op
+ (:reify :deftype)
+ (let [all-methods
+ (into #{}
+ (mapcat (fn [class]
+ (mapv (fn [method]
+ (dissoc method :exception-types))
+ (filter (fn [{:keys [flags return-type]}]
+ (and return-type (not-any? #{:final :static} flags)))
+ (members class))))
+ (conj interfaces Object)))]
+ (assoc ast :methods (mapv (fn [ast]
+ (let [name (:name ast)
+ argc (count (:params ast))]
+ (assoc ast :methods
+ (filter #(and ((name-matches? name) (:name %))
+ (= argc (count (:parameter-types %))))
+ all-methods)))) methods)))
+
+
+ :catch
+ (let [the-class (cond
+
+ (and (= :const (:op class))
+ (= :default (:form class)))
+ Throwable
+
+ (= :maybe-class (:op class))
+ (u/maybe-class-literal (:class class)))
+
+ ast (if the-class
+ (-> ast
+ (assoc :class (assoc (ana/analyze-const the-class env :class)
+ :form (:form class)
+ :tag Class
+ :o-tag Class)))
+ ast)]
+ (assoc-in ast [:local :tag] (-> ast :class :val)))
+
+
+ :method
+ ;; this should actually be in validate but it's here since it needs to be prewalked
+ ;; for infer-tag purposes
+ (let [{:keys [name class tag form params fixed-arity env]} ast]
+ (if interfaces
+ (let [tags (mapv (comp u/maybe-class :tag meta :form) params)
+ methods-set (set (mapv (fn [x] (dissoc x :declaring-class :flags)) methods))]
+ (let [[m & rest :as matches] (try-best-match tags methods)]
+ (if m
+ (let [ret-tag (u/maybe-class (:return-type m))
+ i-tag (u/maybe-class (:declaring-class m))
+ arg-tags (mapv u/maybe-class (:parameter-types m))
+ params (mapv (fn [{:keys [atom] :as arg} tag]
+ (assoc arg :tag tag :o-tag tag)) params arg-tags)]
+ (if (or (empty? rest)
+ (every? (fn [{:keys [return-type parameter-types]}]
+ (and (= (u/maybe-class return-type) ret-tag)
+ (= arg-tags (mapv u/maybe-class parameter-types)))) rest))
+ (assoc (dissoc ast :interfaces :methods)
+ :bridges (filter #(and (= arg-tags (mapv u/maybe-class (:parameter-types %)))
+ (.isAssignableFrom (u/maybe-class (:return-type %)) ret-tag))
+ (disj methods-set (dissoc m :declaring-class :flags)))
+ :methods methods
+ :interface i-tag
+ :tag ret-tag
+ :o-tag ret-tag
+ :params params)
+ (throw (ex-info (str "Ambiguous method signature for method: " name)
+ (merge {:method name
+ :interfaces interfaces
+ :form form
+ :params (mapv (fn [x] (prewalk x cleanup)) params)
+ :matches matches}
+ (source-info env))))))
+ (throw (ex-info (str "No such method found: " name " with given signature in any of the"
+ " provided interfaces: " interfaces)
+ (merge {:method name
+ :methods methods
+ :interfaces interfaces
+ :form form
+ :params params}
+ (source-info env)))))))
+ ast))
+ ast))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj
new file mode 100644
index 000000000..264c5e750
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_loops.clj
@@ -0,0 +1,132 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-loops
+ (:require [clojure.tools.analyzer.ast :refer [update-children]]))
+
+(defmulti annotate-loops
+ "Adds a :loops field to nodes that represent a code path that
+ might be visited more than once because of a recur.
+
+ The field is a set of loop-ids representing the loops that might
+ recur into that path
+
+ Note that because (recur expr) is equivalent to (let [e expr] (recur e))
+ the node corresponting to expr will have the same :loops field
+ as the nodes in the same code path of the recur"
+ {:pass-info {:walk :pre :depends #{}}}
+ :op)
+
+(defmulti check-recur :op)
+
+(defn -check-recur [ast k]
+ (let [ast (update-in ast [k] check-recur)]
+ (if (:recurs (k ast))
+ (assoc ast :recurs true)
+ ast)))
+
+(defmethod check-recur :do
+ [ast]
+ (let [ast (-check-recur ast :ret)]
+ (if (:recurs ast)
+ (assoc ast :statements (mapv (fn [s] (assoc s :recurs true)) (:statements ast)))
+ ast)))
+
+(defmethod check-recur :let
+ [ast]
+ (-check-recur ast :body))
+
+(defmethod check-recur :letfn
+ [ast]
+ (-check-recur ast :body))
+
+(defmethod check-recur :if
+ [ast]
+ (-> ast
+ (-check-recur :then)
+ (-check-recur :else)))
+
+(defmethod check-recur :case
+ [ast]
+ (let [ast (-> ast
+ (-check-recur :default)
+ (update-in [:thens] #(mapv check-recur %)))]
+ (if (some :recurs (:thens ast))
+ (assoc ast :recurs true)
+ ast)))
+
+(defmethod check-recur :case-then
+ [ast]
+ (-check-recur ast :then))
+
+(defmethod check-recur :recur
+ [ast]
+ (assoc ast :recurs true))
+
+(defmethod check-recur :default
+ [ast]
+ ast)
+
+(defn -loops [ast loop-id]
+ (update-in ast [:loops] (fnil conj #{}) loop-id))
+
+(defmethod annotate-loops :loop
+ [{:keys [loops loop-id] :as ast}]
+ (let [ast (if loops
+ (update-children ast #(assoc % :loops loops))
+ ast)
+ ast (update-in ast [:body] check-recur)]
+ (if (-> ast :body :recurs)
+ (update-in ast [:body] -loops loop-id)
+ ast)))
+
+(defmethod annotate-loops :default
+ [{:keys [loops] :as ast}]
+ (if loops
+ (update-children ast #(assoc % :loops loops))
+ ast))
+
+(defmethod annotate-loops :if
+ [{:keys [loops test then else env] :as ast}]
+ (if loops
+ (let [loop-id (:loop-id env)
+ loops-no-recur (disj loops loop-id)
+ branch-recurs? (or (:recurs then) (:recurs else))
+ then (if (or (:recurs then) ;; the recur is inside the then branch
+ ;; the recur is in the same code path of the if expression
+ (not branch-recurs?))
+ (assoc then :loops loops)
+ (assoc then :loops loops-no-recur))
+ else (if (or (:recurs else) (not branch-recurs?))
+ (assoc else :loops loops)
+ (assoc else :loops loops-no-recur))]
+ (assoc ast
+ :then then
+ :else else
+ :test (assoc test :loops loops)))
+ ast))
+
+(defmethod annotate-loops :case
+ [{:keys [loops test default thens env] :as ast}]
+ (if loops
+ (let [loop-id (:loop-id env)
+ loops-no-recur (disj loops loop-id)
+ branch-recurs? (some :recurs (conj thens default))
+
+ default (if (or (:recurs default) (not branch-recurs?))
+ (assoc default :loops loops)
+ (assoc default :loops loops-no-recur))
+
+ thens (mapv #(if (or (:recurs %) (not branch-recurs?))
+ (assoc % :loops loops)
+ (assoc % :loops loops-no-recur)) thens)]
+ (assoc ast
+ :thens thens
+ :default default
+ :test (assoc test :loops loops)))
+ ast))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj
new file mode 100644
index 000000000..92e23f593
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/annotate_tag.clj
@@ -0,0 +1,96 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.annotate-tag
+ (:require [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer [unbox maybe-class]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm.constant-lifter :refer [constant-lift]])
+ (:import (clojure.lang ISeq Var AFunction)))
+
+(defmulti -annotate-tag :op)
+
+(defmethod -annotate-tag :default [ast] ast)
+
+(defmethod -annotate-tag :map
+ [{:keys [val form] :as ast}]
+ (let [t (class (or val form))]
+ (assoc ast :o-tag t :tag t)))
+
+(defmethod -annotate-tag :set
+ [{:keys [val form] :as ast}]
+ (let [t (class (or val form))]
+ (assoc ast :o-tag t :tag t)))
+
+(defmethod -annotate-tag :vector
+ [{:keys [val form] :as ast}]
+ (let [t (class (or val form))]
+ (assoc ast :o-tag t :tag t)))
+
+(defmethod -annotate-tag :the-var
+ [ast]
+ (assoc ast :o-tag Var :tag Var))
+
+(defmethod -annotate-tag :const
+ [ast]
+ (case (:type ast)
+
+ ;; char and numbers are unboxed by default
+ :number
+ (let [t (unbox (class (:val ast)))]
+ (assoc ast :o-tag t :tag t))
+
+ :char
+ (assoc ast :o-tag Character/TYPE :tag Character/TYPE)
+
+ :seq
+ (assoc ast :o-tag ISeq :tag ISeq)
+
+ (let [t (class (:val ast))]
+ (assoc ast :o-tag t :tag t))))
+
+(defmethod -annotate-tag :binding
+ [{:keys [form tag atom o-tag init local name variadic?] :as ast}]
+ (let [o-tag (or (:tag init) ;; should defer to infer-tag?
+ (and (= :fn local) AFunction)
+ (and (= :arg local) variadic? ISeq)
+ o-tag
+ Object)
+ o-tag (if (#{Void Void/TYPE} o-tag)
+ Object
+ o-tag)]
+ (if-let [tag (or (:tag (meta form)) tag)]
+ (let [ast (assoc ast :tag tag :o-tag tag)]
+ (if init
+ (assoc-in ast [:init :tag] (maybe-class tag))
+ ast))
+ (assoc ast :tag o-tag :o-tag o-tag))))
+
+(defmethod -annotate-tag :local
+ [{:keys [name form tag atom case-test] :as ast}]
+ (let [o-tag (@atom :tag)]
+ (assoc ast :o-tag o-tag :tag o-tag)))
+
+;; TODO: move binding/local logic to infer-tag
+(defn annotate-tag
+ "If the AST node type is a constant object or contains :tag metadata,
+ attach the appropriate :tag and :o-tag to the node."
+ {:pass-info {:walk :post :depends #{} :after #{#'constant-lift}}}
+ [{:keys [op tag o-tag atom] :as ast}]
+ (let [ast (if (and atom (:case-test @atom))
+ (update-in ast [:form] vary-meta dissoc :tag)
+ ast)
+ ast
+ (if (and o-tag tag)
+ ast
+ (if-let [tag (or tag
+ (-> ast :val meta :tag)
+ (-> ast :form meta :tag))]
+ (assoc (-annotate-tag ast) :tag tag)
+ (-annotate-tag ast)))]
+ (when (= op :binding)
+ (swap! atom assoc :tag (:tag ast)))
+ ast))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj
new file mode 100644
index 000000000..a7096e29f
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/box.clj
@@ -0,0 +1,200 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.box
+ (:require [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :as u]
+ [clojure.tools.analyzer.utils :refer [protocol-node? arglist-for-arity]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm
+ [validate :refer [validate]]
+ [infer-tag :refer [infer-tag]]]))
+
+(defmulti box
+ "Box the AST node tag where necessary"
+ {:pass-info {:walk :pre :depends #{#'infer-tag} :after #{#'validate}}}
+ :op)
+
+(defmacro if-let-box [class then else]
+ `(let [c# ~class
+ ~class (u/box c#)]
+ (if (u/primitive? c#)
+ ~then
+ ~else)))
+
+(defn -box [ast]
+ (let [tag (:tag ast)]
+ (if (u/primitive? tag)
+ (assoc ast :tag (u/box tag))
+ ast)))
+
+(defn boxed? [tag expr]
+ (and (or (nil? tag) (not (u/primitive? tag)))
+ (u/primitive? (:tag expr))))
+
+(defmethod box :instance-call
+ [{:keys [args class validated? tag] :as ast}]
+ (let [ast (if-let-box class
+ (assoc (update-in ast [:instance :tag] u/box) :class class)
+ ast)]
+ (if validated?
+ ast
+ (assoc ast :args (mapv -box args)
+ :o-tag Object :tag (if (not (#{Void Void/TYPE} tag))
+ tag
+ Object)))))
+
+(defmethod box :static-call
+ [{:keys [args validated? tag] :as ast}]
+ (if validated?
+ ast
+ (assoc ast :args (mapv -box args)
+ :o-tag Object :tag (if (not (#{Void Void/TYPE} tag))
+ tag
+ Object))))
+
+(defmethod box :new
+ [{:keys [args validated?] :as ast}]
+ (if validated?
+ ast
+ (assoc ast :args (mapv -box args)
+ :o-tag Object)))
+
+(defmethod box :instance-field
+ [{:keys [class] :as ast}]
+ (if-let-box class
+ (assoc (update-in ast [:instance :tag] u/box) :class class)
+ ast))
+
+(defmethod box :def
+ [{:keys [init] :as ast}]
+ (if (and init (u/primitive? (:tag init)))
+ (update-in ast [:init] -box)
+ ast))
+
+(defmethod box :vector
+ [ast]
+ (assoc ast :items (mapv -box (:items ast))))
+
+(defmethod box :set
+ [ast]
+ (assoc ast :items (mapv -box (:items ast))))
+
+(defmethod box :map
+ [ast]
+ (let [keys (mapv -box (:keys ast))
+ vals (mapv -box (:vals ast))]
+ (assoc ast
+ :keys keys
+ :vals vals)))
+
+(defmethod box :do
+ [ast]
+ (if (boxed? (:tag ast) (:ret ast))
+ (-> ast
+ (update-in [:ret] -box)
+ (update-in [:o-tag] u/box))
+ ast))
+
+(defmethod box :quote
+ [ast]
+ (if (boxed? (:tag ast) (:ret ast))
+ (-> ast
+ (update-in [:expr] -box)
+ (update-in [:o-tag] u/box))
+ ast))
+
+(defmethod box :protocol-invoke
+ [ast]
+ (assoc ast :args (mapv -box (:args ast))))
+
+(defmethod box :let
+ [{:keys [tag body] :as ast}]
+ (if (boxed? tag body)
+ (-> ast
+ (update-in [:body] -box)
+ (update-in [:o-tag] u/box))
+ ast))
+
+(defmethod box :letfn
+ [ast]
+ (if (boxed? (:tag ast) (:body ast))
+ (-> ast
+ (update-in [:body] -box)
+ (update-in [:o-tag] u/box))
+ ast))
+
+(defmethod box :loop
+ [ast]
+ (if (boxed? (:tag ast) (:body ast))
+ (-> ast
+ (update-in [:body] -box)
+ (update-in [:o-tag] u/box))
+ ast))
+
+(defmethod box :fn-method
+ [{:keys [params tag] :as ast}]
+ (let [ast (if (u/primitive? tag)
+ ast
+ (-> ast
+ (update-in [:body] -box)
+ (update-in [:o-tag] u/box)))]
+ (assoc ast
+ :params (mapv (fn [{:keys [o-tag] :as p}]
+ (assoc p :o-tag (u/prim-or-obj o-tag))) params)
+ :tag (u/prim-or-obj tag)
+ :o-tag (u/prim-or-obj tag))))
+
+(defmethod box :if
+ [{:keys [test then else tag o-tag] :as ast}]
+ (let [test-tag (:tag test)
+ test (if (and (u/primitive? test-tag)
+ (not= Boolean/TYPE test-tag))
+ (assoc test :tag (u/box test-tag))
+ test)
+ [then else o-tag] (if (or (boxed? tag then)
+ (boxed? tag else)
+ (not o-tag))
+ (conj (mapv -box [then else]) (u/box o-tag))
+ [then else o-tag])]
+ (merge ast
+ {:test test
+ :o-tag o-tag
+ :then then
+ :else else})))
+
+(defmethod box :case
+ [{:keys [tag default tests thens test-type] :as ast}]
+ (let [ast (if (and tag (u/primitive? tag))
+ ast
+ (-> ast
+ (assoc-in [:thens] (mapv (fn [t] (update-in t [:then] -box)) thens))
+ (update-in [:default] -box)
+ (update-in [:o-tag] u/box)))]
+ (if (= :hash-equiv test-type)
+ (-> ast
+ (update-in [:test] -box)
+ (assoc-in [:tests] (mapv (fn [t] (update-in t [:test] -box)) tests)))
+ ast)))
+
+(defmethod box :try
+ [{:keys [tag] :as ast}]
+ (let [ast (if (and tag (u/primitive? tag))
+ ast
+ (-> ast
+ (update-in [:catches] #(mapv -box %))
+ (update-in [:body] -box)
+ (update-in [:o-tag] u/box)))]
+ (-> ast
+ (update-in [:finally] -box))))
+
+(defmethod box :invoke
+ [ast]
+ (assoc ast
+ :args (mapv -box (:args ast))
+ :o-tag Object))
+
+(defmethod box :default [ast] ast)
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj
new file mode 100644
index 000000000..ad3da1695
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/classify_invoke.clj
@@ -0,0 +1,91 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.classify-invoke
+ (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity protocol-node? source-info]]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils
+ :refer [specials prim-interface]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate :refer [validate]]))
+
+(defn classify-invoke
+ "If the AST node is an :invoke, check the node in function position,
+ * if it is a keyword, transform the node in a :keyword-invoke node;
+ * if it is the clojure.core/instance? var and the first argument is a
+ literal class, transform the node in a :instance? node to be inlined by
+ the emitter
+ * if it is a protocol function var, transform the node in a :protocol-invoke
+ node
+ * if it is a regular function with primitive type hints that match a
+ clojure.lang.IFn$[primitive interface], transform the node in a :prim-invoke
+ node"
+ {:pass-info {:walk :post :depends #{#'validate}}}
+ [{:keys [op args tag env form] :as ast}]
+ (if-not (= op :invoke)
+ ast
+ (let [argc (count args)
+ the-fn (:fn ast)
+ op (:op the-fn)
+ var? (= :var op)
+ the-var (:var the-fn)]
+
+ (cond
+
+ (and (= :const op)
+ (= :keyword (:type the-fn)))
+ (if (<= 1 argc 2)
+ (if (and (not (namespace (:val the-fn)))
+ (= 1 argc))
+ (merge (dissoc ast :fn :args)
+ {:op :keyword-invoke
+ :target (first args)
+ :keyword the-fn
+ :children [:keyword :target]})
+ ast)
+ (throw (ex-info (str "Cannot invoke keyword with " argc " arguments")
+ (merge {:form form}
+ (source-info env)))))
+ (and (= 2 argc)
+ var?
+ (= #'clojure.core/instance? the-var)
+ (= :const (:op (first args)))
+ (= :class (:type (first args))))
+ (merge (dissoc ast :fn :args)
+ {:op :instance?
+ :class (:val (first args))
+ :target (second args)
+ :form form
+ :env env
+ :o-tag Boolean/TYPE
+ :tag (or tag Boolean/TYPE)
+ :children [:target]})
+
+ (and var? (protocol-node? the-var (:meta the-fn)))
+ (if (>= argc 1)
+ (merge (dissoc ast :fn)
+ {:op :protocol-invoke
+ :protocol-fn the-fn
+ :target (first args)
+ :args (vec (rest args))
+ :children [:protocol-fn :target :args]})
+ (throw (ex-info "Cannot invoke protocol method with no args"
+ (merge {:form form}
+ (source-info env)))))
+
+ :else
+ (let [arglist (arglist-for-arity the-fn argc)
+ arg-tags (mapv (comp specials str :tag meta) arglist)
+ ret-tag (-> arglist meta :tag str specials)
+ tags (conj arg-tags ret-tag)]
+ (if-let [prim-interface (prim-interface (mapv #(if (nil? %) Object %) tags))]
+ (merge ast
+ {:op :prim-invoke
+ :prim-interface prim-interface
+ :args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)
+ :o-tag ret-tag
+ :tag (or tag ret-tag)})
+ ast))))))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj
new file mode 100644
index 000000000..f9b35c632
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/constant_lifter.clj
@@ -0,0 +1,26 @@
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.constant-lifter
+ (:require [clojure.tools.analyzer.passes.constant-lifter :as orig]
+ [clojure.tools.analyzer :refer [analyze-const]]
+ [clojure.tools.analyzer.utils :refer [constant? classify]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm.analyze-host-expr :refer [analyze-host-expr]]
+ [clojure.tools.analyzer.passes.elide-meta :refer [elide-meta]]))
+
+(defn constant-lift*
+ [ast]
+ (if (= :var (:op ast))
+ (let [{:keys [var env form meta]} ast]
+ (if (constant? var meta)
+ (let [val @var]
+ (assoc (analyze-const val env (classify val))
+ :form form))
+ ast))
+ (orig/constant-lift ast)))
+
+(defn constant-lift
+ "Like clojure.tools.analyzer.passes.constant-lifter/constant-lift but
+ transforms also :var nodes where the var has :const in the metadata
+ into :const nodes and preserves tag info"
+ {:pass-info {:walk :post :depends #{} :after #{#'elide-meta #'analyze-host-expr}}}
+ [ast]
+ (merge (constant-lift* ast)
+ (select-keys ast [:tag :o-tag :return-tag :arglists])))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj
new file mode 100644
index 000000000..7246fca13
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/emit_form.clj
@@ -0,0 +1,169 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.emit-form
+ (:require [clojure.tools.analyzer.passes
+ [emit-form :as default]
+ [uniquify :refer [uniquify-locals]]]))
+
+(defmulti -emit-form (fn [{:keys [op]} _] op))
+
+(defn -emit-form*
+ [{:keys [form] :as ast} opts]
+ (let [expr (-emit-form ast opts)]
+ (if-let [m (and (instance? clojure.lang.IObj expr)
+ (meta form))]
+ (with-meta expr (merge m (meta expr)))
+ expr)))
+
+;; TODO: use pass opts infr
+(defn emit-form
+ "Return the form represented by the given AST
+ Opts is a set of options, valid options are:
+ * :hygienic
+ * :qualified-vars (DEPRECATED, use :qualified-symbols instead)
+ * :qualified-symbols"
+ {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}}
+ ([ast] (emit-form ast #{}))
+ ([ast opts]
+ (binding [default/-emit-form* -emit-form*]
+ (-emit-form* ast opts))))
+
+(defn emit-hygienic-form
+ "Return an hygienic form represented by the given AST"
+ {:pass-info {:walk :none :depends #{#'uniquify-locals} :compiler true}}
+ [ast]
+ (binding [default/-emit-form* -emit-form*]
+ (-emit-form* ast #{:hygienic})))
+
+(defmethod -emit-form :default
+ [ast opts]
+ (default/-emit-form ast opts))
+
+(defmethod -emit-form :const
+ [{:keys [type val] :as ast} opts]
+ (if (and (= type :class)
+ (:qualified-symbols opts))
+ (symbol (.getName ^Class val))
+ (default/-emit-form ast opts)))
+
+(defmethod -emit-form :monitor-enter
+ [{:keys [target]} opts]
+ `(monitor-enter ~(-emit-form* target opts)))
+
+(defmethod -emit-form :monitor-exit
+ [{:keys [target]} opts]
+ `(monitor-exit ~(-emit-form* target opts)))
+
+(defmethod -emit-form :import
+ [{:keys [class]} opts]
+ `(clojure.core/import* ~class))
+
+(defmethod -emit-form :the-var
+ [{:keys [^clojure.lang.Var var]} opts]
+ `(var ~(symbol (name (ns-name (.ns var))) (name (.sym var)))))
+
+(defmethod -emit-form :method
+ [{:keys [params body this name form]} opts]
+ (let [params (into [this] params)]
+ `(~(with-meta name (meta (first form)))
+ ~(with-meta (mapv #(-emit-form* % opts) params)
+ (meta (second form)))
+ ~(-emit-form* body opts))))
+
+(defn class->str [class]
+ (if (symbol? class)
+ (name class)
+ (.getName ^Class class)))
+
+(defn class->sym [class]
+ (if (symbol? class)
+ class
+ (symbol (.getName ^Class class))))
+
+(defmethod -emit-form :catch
+ [{:keys [class local body]} opts]
+ `(catch ~(-emit-form* class opts) ~(-emit-form* local opts)
+ ~(-emit-form* body opts)))
+
+(defmethod -emit-form :deftype
+ [{:keys [name class-name fields interfaces methods]} opts]
+ `(deftype* ~name ~(class->sym class-name) ~(mapv #(-emit-form* % opts) fields)
+ :implements ~(mapv class->sym interfaces)
+ ~@(mapv #(-emit-form* % opts) methods)))
+
+(defmethod -emit-form :reify
+ [{:keys [interfaces methods]} opts]
+ `(reify* ~(mapv class->sym (disj interfaces clojure.lang.IObj))
+ ~@(mapv #(-emit-form* % opts) methods)))
+
+(defmethod -emit-form :case
+ [{:keys [test default tests thens shift mask low high switch-type test-type skip-check?]} opts]
+ `(case* ~(-emit-form* test opts)
+ ~shift ~mask
+ ~(-emit-form* default opts)
+ ~(apply sorted-map
+ (mapcat (fn [{:keys [hash test]} {:keys [then]}]
+ [hash [(-emit-form* test opts) (-emit-form* then opts)]])
+ tests thens))
+ ~switch-type ~test-type ~skip-check?))
+
+(defmethod -emit-form :static-field
+ [{:keys [class field]} opts]
+ (symbol (class->str class) (name field)))
+
+(defmethod -emit-form :static-call
+ [{:keys [class method args]} opts]
+ `(~(symbol (class->str class) (name method))
+ ~@(mapv #(-emit-form* % opts) args)))
+
+(defmethod -emit-form :instance-field
+ [{:keys [instance field]} opts]
+ `(~(symbol (str ".-" (name field))) ~(-emit-form* instance opts)))
+
+(defmethod -emit-form :instance-call
+ [{:keys [instance method args]} opts]
+ `(~(symbol (str "." (name method))) ~(-emit-form* instance opts)
+ ~@(mapv #(-emit-form* % opts) args)))
+
+(defmethod -emit-form :prim-invoke
+ [{:keys [fn args]} opts]
+ `(~(-emit-form* fn opts)
+ ~@(mapv #(-emit-form* % opts) args)))
+
+(defmethod -emit-form :protocol-invoke
+ [{:keys [protocol-fn target args]} opts]
+ `(~(-emit-form* protocol-fn opts)
+ ~(-emit-form* target opts)
+ ~@(mapv #(-emit-form* % opts) args)))
+
+(defmethod -emit-form :keyword-invoke
+ [{:keys [target keyword]} opts]
+ (list (-emit-form* keyword opts)
+ (-emit-form* target opts)))
+
+(defmethod -emit-form :instance?
+ [{:keys [class target]} opts]
+ `(instance? ~class ~(-emit-form* target opts)))
+
+(defmethod -emit-form :var
+ [{:keys [form ^clojure.lang.Var var]} opts]
+ (if (or (:qualified-symbols opts)
+ (:qualified-vars opts))
+ (with-meta (symbol (-> var .ns ns-name name) (-> var .sym name))
+ (meta form))
+ form))
+
+(defmethod -emit-form :def
+ [ast opts]
+ (let [f (default/-emit-form ast opts)]
+ (if (:qualified-symbols opts)
+ `(def ~(with-meta (symbol (-> ast :env :ns name) (str (second f)))
+ (meta (second f)))
+ ~@(nthrest f 2))
+ f)))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj
new file mode 100644
index 000000000..b21d08a7f
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/fix_case_test.clj
@@ -0,0 +1,19 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.fix-case-test
+ (:require [clojure.tools.analyzer.passes.add-binding-atom :refer [add-binding-atom]]))
+
+(defn fix-case-test
+ "If the node is a :case-test, annotates in the atom shared
+ by the binding and the local node with :case-test"
+ {:pass-info {:walk :pre :depends #{#'add-binding-atom}}}
+ [ast]
+ (when (:case-test ast)
+ (swap! (:atom ast) assoc :case-test true))
+ ast)
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj
new file mode 100644
index 000000000..356bf4152
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/infer_tag.clj
@@ -0,0 +1,280 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.infer-tag
+ (:require [clojure.tools.analyzer.utils :refer [arglist-for-arity]]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :as u]
+ [clojure.tools.analyzer.env :as env]
+ [clojure.set :refer [rename-keys]]
+ [clojure.tools.analyzer.passes.trim :refer [trim]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm
+ [annotate-tag :refer [annotate-tag]]
+ [annotate-host-info :refer [annotate-host-info]]
+ [analyze-host-expr :refer [analyze-host-expr]]
+ [fix-case-test :refer [fix-case-test]]]))
+
+(defmulti -infer-tag :op)
+(defmethod -infer-tag :default [ast] ast)
+
+(defmethod -infer-tag :binding
+ [{:keys [init atom] :as ast}]
+ (if init
+ (let [info (select-keys init [:return-tag :arglists])]
+ (swap! atom merge info)
+ (merge ast info))
+ ast))
+
+(defmethod -infer-tag :local
+ [ast]
+ (let [atom @(:atom ast)]
+ (merge atom
+ ast
+ {:o-tag (:tag atom)})))
+
+(defmethod -infer-tag :var
+ [{:keys [var form] :as ast}]
+ (let [{:keys [tag arglists]} (:meta ast)
+ arglists (if (= 'quote (first arglists))
+ (second arglists)
+ arglists)
+ form-tag (:tag (meta form))]
+ ;;if (not dynamic)
+ (merge ast
+ {:o-tag Object}
+ (when-let [tag (or form-tag tag)]
+ (if (fn? @var)
+ {:tag clojure.lang.AFunction :return-tag tag}
+ {:tag tag}))
+ (when arglists
+ {:arglists arglists}))))
+
+(defmethod -infer-tag :def
+ [{:keys [var init name] :as ast}]
+ (let [info (merge (select-keys init [:return-tag :arglists :tag])
+ (select-keys (meta name) [:tag :arglists]))]
+ (when (and (seq info)
+ (not (:dynamic (meta name)))
+ (= :global (-> (env/deref-env) :passes-opts :infer-tag/level)))
+ (alter-meta! var merge (rename-keys info {:return-tag :tag})))
+ (merge ast info {:tag clojure.lang.Var :o-tag clojure.lang.Var})))
+
+(defmethod -infer-tag :quote
+ [ast]
+ (let [tag (-> ast :expr :tag)]
+ (assoc ast :tag tag :o-tag tag)))
+
+(defmethod -infer-tag :new
+ [ast]
+ (let [t (-> ast :class :val)]
+ (assoc ast :o-tag t :tag t)))
+
+(defmethod -infer-tag :with-meta
+ [{:keys [expr] :as ast}]
+ (merge ast (select-keys expr [:return-tag :arglists])
+ {:tag (or (:tag expr) Object) :o-tag Object})) ;;trying to be smart here
+
+(defmethod -infer-tag :recur
+ [ast]
+ (assoc ast :ignore-tag true))
+
+(defmethod -infer-tag :do
+ [{:keys [ret] :as ast}]
+ (merge ast (select-keys ret [:return-tag :arglists :ignore-tag :tag])
+ {:o-tag (:tag ret)}))
+
+(defmethod -infer-tag :let
+ [{:keys [body] :as ast}]
+ (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag])
+ {:o-tag (:tag body)}))
+
+(defmethod -infer-tag :letfn
+ [{:keys [body] :as ast}]
+ (merge ast (select-keys body [:return-tag :arglists :ignore-tag :tag])
+ {:o-tag (:tag body)}))
+
+(defmethod -infer-tag :loop
+ [{:keys [body] :as ast}]
+ (merge ast (select-keys body [:return-tag :arglists])
+ {:o-tag (:tag body)}
+ (let [tag (:tag body)]
+ (if (#{Void Void/TYPE} tag)
+ (assoc ast :tag Object)
+ (assoc ast :tag tag)))))
+
+(defn =-arglists? [a1 a2]
+ (let [tag (fn [x] (-> x meta :tag u/maybe-class))]
+ (and (= a1 a2)
+ (every? true? (mapv (fn [a1 a2]
+ (and (= (tag a1) (tag a2))
+ (= (mapv tag a1)
+ (mapv tag a2))))
+ a1 a2)))))
+
+(defmethod -infer-tag :if
+ [{:keys [then else] :as ast}]
+ (let [then-tag (:tag then)
+ else-tag (:tag else)
+ ignore-then? (:ignore-tag then)
+ ignore-else? (:ignore-tag else)]
+ (cond
+ (and then-tag
+ (or ignore-else? (= then-tag else-tag)))
+ (merge ast
+ {:tag then-tag :o-tag then-tag}
+ (when-let [return-tag (:return-tag then)]
+ (when (or ignore-else?
+ (= return-tag (:return-tag else)))
+ {:return-tag return-tag}))
+ (when-let [arglists (:arglists then)]
+ (when (or ignore-else?
+ (=-arglists? arglists (:arglists else)))
+ {:arglists arglists})))
+
+ (and else-tag ignore-then?)
+ (merge ast
+ {:tag else-tag :o-tag else-tag}
+ (when-let [return-tag (:return-tag else)]
+ {:return-tag return-tag})
+ (when-let [arglists (:arglists else)]
+ {:arglists arglists}))
+
+ (and (:ignore-tag then) (:ignore-tag else))
+ (assoc ast :ignore-tag true)
+
+ :else
+ ast)))
+
+(defmethod -infer-tag :throw
+ [ast]
+ (assoc ast :ignore-tag true))
+
+(defmethod -infer-tag :case
+ [{:keys [thens default] :as ast}]
+ (let [thens (conj (mapv :then thens) default)
+ exprs (seq (remove :ignore-tag thens))
+ tag (:tag (first exprs))]
+ (cond
+ (and tag
+ (every? #(= (:tag %) tag) exprs))
+ (merge ast
+ {:tag tag :o-tag tag}
+ (when-let [return-tag (:return-tag (first exprs))]
+ (when (every? #(= (:return-tag %) return-tag) exprs)
+ {:return-tag return-tag}))
+ (when-let [arglists (:arglists (first exprs))]
+ (when (every? #(=-arglists? (:arglists %) arglists) exprs)
+ {:arglists arglists})))
+
+ (every? :ignore-tag thens)
+ (assoc ast :ignore-tag true)
+
+ :else
+ ast)))
+
+(defmethod -infer-tag :try
+ [{:keys [body catches] :as ast}]
+ (let [{:keys [tag return-tag arglists]} body
+ catches (remove :ignore-tag (mapv :body catches))]
+ (merge ast
+ (when (and tag (every? #(= % tag) (mapv :tag catches)))
+ {:tag tag :o-tag tag})
+ (when (and return-tag (every? #(= % return-tag) (mapv :return-tag catches)))
+ {:return-tag return-tag})
+ (when (and arglists (every? #(=-arglists? % arglists) (mapv :arglists catches)))
+ {:arglists arglists}))))
+
+(defmethod -infer-tag :fn-method
+ [{:keys [form body params local] :as ast}]
+ (let [annotated-tag (or (:tag (meta (first form)))
+ (:tag (meta (:form local))))
+ body-tag (:tag body)
+ tag (or annotated-tag body-tag)
+ tag (if (#{Void Void/TYPE} tag)
+ Object
+ tag)]
+ (merge (if (not= tag body-tag)
+ (assoc-in ast [:body :tag] (u/maybe-class tag))
+ ast)
+ (when tag
+ {:tag tag
+ :o-tag tag})
+ {:arglist (with-meta (vec (mapcat (fn [{:keys [form variadic?]}]
+ (if variadic? ['& form] [form]))
+ params))
+ (when tag {:tag tag}))})))
+
+(defmethod -infer-tag :fn
+ [{:keys [local methods] :as ast}]
+ (merge ast
+ {:arglists (seq (mapv :arglist methods))
+ :tag clojure.lang.AFunction
+ :o-tag clojure.lang.AFunction}
+ (when-let [tag (or (:tag (meta (:form local)))
+ (and (apply = (mapv :tag methods))
+ (:tag (first methods))))]
+ {:return-tag tag})))
+
+(defmethod -infer-tag :invoke
+ [{:keys [fn args] :as ast}]
+ (if (:arglists fn)
+ (let [argc (count args)
+ arglist (arglist-for-arity fn argc)
+ tag (or (:tag (meta arglist))
+ (:return-tag fn)
+ (and (= :var (:op fn))
+ (:tag (:meta fn))))]
+ (merge ast
+ (when tag
+ {:tag tag
+ :o-tag tag})))
+ (if-let [tag (:return-tag fn)]
+ (assoc ast :tag tag :o-tag tag)
+ ast)))
+
+(defmethod -infer-tag :method
+ [{:keys [form body params] :as ast}]
+ (let [tag (or (:tag (meta (first form)))
+ (:tag (meta (second form))))
+ body-tag (:tag body)]
+ (assoc ast :tag (or tag body-tag) :o-tag body-tag)))
+
+(defmethod -infer-tag :reify
+ [{:keys [class-name] :as ast}]
+ (assoc ast :tag class-name :o-tag class-name))
+
+(defmethod -infer-tag :set!
+ [ast]
+ (let [t (:tag (:target ast))]
+ (assoc ast :tag t :o-tag t)))
+
+(defn infer-tag
+ "Performs local type inference on the AST adds, when possible,
+ one or more of the following keys to the AST:
+ * :o-tag represents the current type of the
+ expression represented by the node
+ * :tag represents the type the expression represented by the
+ node is required to have, possibly the same as :o-tag
+ * :return-tag implies that the node will return a function whose
+ invocation will result in a object of this type
+ * :arglists implies that the node will return a function with
+ this arglists
+ * :ignore-tag true when the node is untyped, does not imply that
+ all untyped node will have this
+
+ Passes opts:
+ * :infer-tag/level If :global, infer-tag will perform Var tag
+ inference"
+ {:pass-info {:walk :post :depends #{#'annotate-tag #'annotate-host-info #'fix-case-test #'analyze-host-expr} :after #{#'trim}}}
+ [{:keys [tag form] :as ast}]
+ (let [tag (or tag (:tag (meta form)))
+ ast (-infer-tag ast)]
+ (merge ast
+ (when tag
+ {:tag tag})
+ (when-let [o-tag (:o-tag ast)]
+ {:o-tag o-tag}))))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj
new file mode 100644
index 000000000..b75304fb5
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate.clj
@@ -0,0 +1,274 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate
+ (:require [clojure.tools.analyzer.ast :refer [prewalk]]
+ [clojure.tools.analyzer.env :as env]
+ [clojure.tools.analyzer.passes.cleanup :refer [cleanup]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm
+ [validate-recur :refer [validate-recur]]
+ [infer-tag :refer [infer-tag]]
+ [analyze-host-expr :refer [analyze-host-expr]]]
+ [clojure.tools.analyzer.utils :refer [arglist-for-arity source-info resolve-sym resolve-ns merge']]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :as u :refer [tag-match? try-best-match]])
+ (:import (clojure.lang IFn ExceptionInfo)))
+
+(defmulti -validate :op)
+
+(defmethod -validate :maybe-class
+ [{:keys [class env] :as ast}]
+ (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)]
+ (handle nil class ast)
+ (if (not (.contains (str class) "."))
+ (throw (ex-info (str "Could not resolve var: " class)
+ (merge {:var class}
+ (source-info env))))
+
+ (throw (ex-info (str "Class not found: " class)
+ (merge {:class class}
+ (source-info env)))))))
+
+(defmethod -validate :maybe-host-form
+ [{:keys [class field form env] :as ast}]
+ (if-let [handle (-> (env/deref-env) :passes-opts :validate/unresolvable-symbol-handler)]
+ (handle class field ast)
+ (if (resolve-ns class env)
+ (throw (ex-info (str "No such var: " class)
+ (merge {:form form}
+ (source-info env))))
+ (throw (ex-info (str "No such namespace: " class)
+ (merge {:ns class
+ :form form}
+ (source-info env)))))))
+
+(defmethod -validate :set!
+ [{:keys [target form env] :as ast}]
+ (when (not (:assignable? target))
+ (throw (ex-info "Cannot set! non-assignable target"
+ (merge {:target (prewalk target cleanup)
+ :form form}
+ (source-info env)))))
+ ast)
+
+(defmethod -validate :new
+ [{:keys [args] :as ast}]
+ (if (:validated? ast)
+ ast
+ (if-not (= :class (-> ast :class :type))
+ (throw (ex-info (str "Unable to resolve classname: " (:form (:class ast)))
+ (merge {:class (:form (:class ast))
+ :ast ast}
+ (source-info (:env ast)))))
+ (let [^Class class (-> ast :class :val)
+ c-name (symbol (.getName class))
+ argc (count args)
+ tags (mapv :tag args)]
+ (let [[ctor & rest] (->> (filter #(= (count (:parameter-types %)) argc)
+ (u/members class c-name))
+ (try-best-match tags))]
+ (if ctor
+ (if (empty? rest)
+ (let [arg-tags (mapv u/maybe-class (:parameter-types ctor))
+ args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)]
+ (assoc ast
+ :args args
+ :validated? true))
+ ast)
+ (throw (ex-info (str "no ctor found for ctor of class: " class " and given signature")
+ (merge {:class class
+ :args (mapv (fn [a] (prewalk a cleanup)) args)}
+ (source-info (:env ast)))))))))))
+
+(defn validate-call [{:keys [class instance method args tag env op] :as ast}]
+ (let [argc (count args)
+ instance? (= :instance-call op)
+ f (if instance? u/instance-methods u/static-methods)
+ tags (mapv :tag args)]
+ (if-let [matching-methods (seq (f class method argc))]
+ (let [[m & rest :as matching] (try-best-match tags matching-methods)]
+ (if m
+ (let [all-ret-equals? (apply = (mapv :return-type matching))]
+ (if (or (empty? rest)
+ (and all-ret-equals? ;; if the method signature is the same just pick the first one
+ (apply = (mapv #(mapv u/maybe-class (:parameter-types %)) matching))))
+ (let [ret-tag (:return-type m)
+ arg-tags (mapv u/maybe-class (:parameter-types m))
+ args (mapv (fn [arg tag] (assoc arg :tag tag)) args arg-tags)
+ class (u/maybe-class (:declaring-class m))]
+ (merge' ast
+ {:method (:name m)
+ :validated? true
+ :class class
+ :o-tag ret-tag
+ :tag (or tag ret-tag)
+ :args args}
+ (if instance?
+ {:instance (assoc instance :tag class)})))
+ (if all-ret-equals?
+ (let [ret-tag (:return-type m)]
+ (assoc ast
+ :o-tag Object
+ :tag (or tag ret-tag)))
+ ast)))
+ (if instance?
+ (assoc (dissoc ast :class) :tag Object :o-tag Object)
+ (throw (ex-info (str "No matching method: " method " for class: " class " and given signature")
+ (merge {:method method
+ :class class
+ :args (mapv (fn [a] (prewalk a cleanup)) args)}
+ (source-info env)))))))
+ (if instance?
+ (assoc (dissoc ast :class) :tag Object :o-tag Object)
+ (throw (ex-info (str "No matching method: " method " for class: " class " and arity: " argc)
+ (merge {:method method
+ :class class
+ :argc argc}
+ (source-info env))))))))
+
+(defmethod -validate :static-call
+ [ast]
+ (if (:validated? ast)
+ ast
+ (validate-call (assoc ast :class (u/maybe-class (:class ast))))))
+
+(defmethod -validate :static-field
+ [ast]
+ (if (:validated? ast)
+ ast
+ (assoc ast :class (u/maybe-class (:class ast)))))
+
+(defmethod -validate :instance-call
+ [{:keys [class validated? instance] :as ast}]
+ (let [class (or class (:tag instance))]
+ (if (and class (not validated?))
+ (validate-call (assoc ast :class (u/maybe-class class)))
+ ast)))
+
+(defmethod -validate :instance-field
+ [{:keys [instance class] :as ast}]
+ (let [class (u/maybe-class class)]
+ (assoc ast :class class :instance (assoc instance :tag class))))
+
+(defmethod -validate :import
+ [{:keys [^String class validated? env form] :as ast}]
+ (if-not validated?
+ (let [class-sym (-> class (subs (inc (.lastIndexOf class "."))) symbol)
+ sym-val (resolve-sym class-sym env)]
+ (if (and (class? sym-val) (not= (.getName ^Class sym-val) class)) ;; allow deftype redef
+ (throw (ex-info (str class-sym " already refers to: " sym-val
+ " in namespace: " (:ns env))
+ (merge {:class class
+ :class-sym class-sym
+ :sym-val sym-val
+ :form form}
+ (source-info env))))
+ (assoc ast :validated? true)))
+ ast))
+
+(defmethod -validate :def
+ [ast]
+ (when-not (var? (:var ast))
+ (throw (ex-info (str "Cannot def " (:name ast) " as it refers to the class "
+ (.getName ^Class (:var ast)))
+ (merge {:ast (prewalk ast cleanup)}
+ (source-info (:env ast))))))
+ (merge
+ ast
+ (when-let [tag (-> ast :name meta :tag)]
+ (when (and (symbol? tag) (or (u/specials (str tag)) (u/special-arrays (str tag))))
+ ;; we cannot validate all tags since :tag might contain a function call that returns
+ ;; a valid tag at runtime, however if tag is one of u/specials or u/special-arrays
+ ;; we know that it's a wrong tag as it's going to be evaluated as a clojure.core function
+ (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)]
+ (handle :name/tag ast)
+ (throw (ex-info (str "Wrong tag: " (eval tag) " in def: " (:name ast))
+ (merge {:ast (prewalk ast cleanup)}
+ (source-info (:env ast))))))))))
+
+(defmethod -validate :invoke
+ [{:keys [args env fn form] :as ast}]
+ (let [argc (count args)]
+ (when (and (= :const (:op fn))
+ (not (instance? IFn (:form fn))))
+ (throw (ex-info (str (class (:form fn)) " is not a function, but it's used as such")
+ (merge {:form form}
+ (source-info env)))))
+ (if (and (:arglists fn)
+ (not (arglist-for-arity fn argc)))
+ (if (-> (env/deref-env) :passes-opts :validate/throw-on-arity-mismatch)
+ (throw (ex-info (str "No matching arity found for function: " (:name fn))
+ {:arity (count args)
+ :fn fn}))
+ (assoc ast :maybe-arity-mismatch true))
+ ast)))
+
+(defn validate-interfaces [{:keys [env form interfaces]}]
+ (when-not (every? #(.isInterface ^Class %) (disj interfaces Object))
+ (throw (ex-info "only interfaces or Object can be implemented by deftype/reify"
+ (merge {:interfaces interfaces
+ :form form}
+ (source-info env))))))
+
+(defmethod -validate :deftype
+ [{:keys [class-name] :as ast}]
+ (validate-interfaces ast)
+ (assoc ast :class-name (u/maybe-class class-name)))
+
+(defmethod -validate :reify
+ [{:keys [class-name] :as ast}]
+ (validate-interfaces ast)
+ (assoc ast :class-name (u/maybe-class class-name)))
+
+(defmethod -validate :default [ast] ast)
+
+(defn validate-tag [t {:keys [env] :as ast}]
+ (let [tag (ast t)]
+ (if-let [the-class (u/maybe-class tag)]
+ {t the-class}
+ (if-let [handle (-> (env/deref-env) :passes-opts :validate/wrong-tag-handler)]
+ (handle t ast)
+ (throw (ex-info (str "Class not found: " tag)
+ (merge {:class tag
+ :ast (prewalk ast cleanup)}
+ (source-info env))))))))
+
+(defn validate
+ "Validate tags, classes, method calls.
+ Throws exceptions when invalid forms are encountered, replaces
+ class symbols with class objects.
+
+ Passes opts:
+ * :validate/throw-on-arity-mismatch
+ If true, validate will throw on potential arity mismatch
+ * :validate/wrong-tag-handler
+ If bound to a function, will invoke that function instead of
+ throwing on invalid tag.
+ The function takes the tag key (or :name/tag if the node is :def and
+ the wrong tag is the one on the :name field meta) and the originating
+ AST node and must return a map (or nil) that will be merged into the AST,
+ possibly shadowing the wrong tag with Object or nil.
+ * :validate/unresolvable-symbol-handler
+ If bound to a function, will invoke that function instead of
+ throwing on unresolvable symbol.
+ The function takes three arguments: the namespace (possibly nil)
+ and name part of the symbol, as symbols and the originating
+ AST node which can be either a :maybe-class or a :maybe-host-form,
+ those nodes are documented in the tools.analyzer quickref.
+ The function must return a valid tools.analyzer.jvm AST node."
+ {:pass-info {:walk :post :depends #{#'infer-tag #'analyze-host-expr #'validate-recur}}}
+ [{:keys [tag form env] :as ast}]
+ (let [ast (merge (-validate ast)
+ (when tag
+ {:tag tag}))]
+ (merge ast
+ (when (:tag ast)
+ (validate-tag :tag ast))
+ (when (:o-tag ast)
+ (validate-tag :o-tag ast))
+ (when (:return-tag ast)
+ (validate-tag :return-tag ast)))))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj
new file mode 100644
index 000000000..8d18ea400
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_loop_locals.clj
@@ -0,0 +1,152 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate-loop-locals
+ (:require [clojure.tools.analyzer.ast :refer [postwalk children update-children]]
+ [nextjournal.clerk.clojure.tools.analyzer.jvm.utils :refer [wider-tag maybe-class primitive?]]
+ [nextjournal.clerk.clojure.tools.analyzer.passes.jvm
+ [validate :refer [validate]]
+ [classify-invoke :refer [classify-invoke]]
+ [infer-tag :refer [infer-tag]]
+ [analyze-host-expr :refer [analyze-host-expr]]]))
+
+(def ^:dynamic ^:private validating nil)
+(def ^:dynamic ^:private mismatch?)
+(def ^:dynamic ^:private *loop-locals* [])
+
+(defn find-mismatches [{:keys [op exprs] :as ast} bindings]
+ (case op
+ :recur
+ (when (some true? (mapv (fn [e {:keys [tag init form]}]
+ (and (or (primitive? tag)
+ (not (or (:tag (meta form))
+ (:tag (meta (:form init))))))
+ (not= (:tag e) tag))) exprs bindings))
+ (swap! mismatch? conj (mapv :tag exprs)))
+ :do
+ (doseq [child (children ast)]
+ (find-mismatches child bindings))
+ (:let :letfn)
+ (find-mismatches (:body ast) bindings)
+ :if
+ (do (find-mismatches (:then ast) bindings)
+ (find-mismatches (:else ast) bindings))
+ :case
+ (do (find-mismatches (:default ast) bindings)
+ (doseq [child (:thens ast)]
+ (find-mismatches child bindings)))
+ nil)
+ ast)
+
+(defmulti -validate-loop-locals (fn [_ {:keys [op]}] op))
+(defmulti -cleanup-dirty-nodes :op)
+
+(defmethod -cleanup-dirty-nodes :local
+ [{:keys [form name atom env] :as ast}]
+ (if-let [cast ((:loop-locals-casts env) name)]
+ (assoc ast
+ :dirty? true
+ :o-tag cast
+ :tag (or (:tag (meta form)) cast))
+ (if (and (:dirty? @atom)
+ (not (:tag (meta form))))
+ (dissoc (assoc ast :dirty? true) :o-tag :tag)
+ ast)))
+
+(defn dirty [ast]
+ (when-let [atom (:atom ast)]
+ (swap! atom assoc :dirty? true))
+ (assoc (update-children ast (fn [ast] (dissoc ast :dirty?)))
+ :dirty? true))
+
+(defmethod -cleanup-dirty-nodes :do
+ [{:keys [op ret] :as ast}]
+ (if (:dirty? ret)
+ (dissoc (dirty ast) :tag)
+ ast))
+
+;; should check for :tag meta form
+(defmethod -cleanup-dirty-nodes :default
+ [{:keys [op] :as ast}]
+ (if (some :dirty? (children ast))
+ (dissoc (dirty ast)
+ :tag :validated? (when (= :instance-call op) :class))
+ ast))
+
+(defn -validate-loop-locals*
+ [analyze {:keys [body env loop-id] :as ast} key]
+ (if validating
+ ast
+ (binding [mismatch? (atom #{})]
+ (let [bindings (key ast)]
+ (find-mismatches body bindings)
+ (if-let [mismatches (seq @mismatch?)]
+ (let [bindings-form (apply mapv
+ (fn [{:keys [form tag]} & mismatches]
+ (when-not (every? #{tag} mismatches)
+ (let [tags (conj mismatches tag)]
+ (with-meta form {:tag (or (and (some primitive? tags)
+ (wider-tag tags))
+ Object)}))))
+ bindings mismatches)
+ loop-locals (mapv :name bindings)
+ binds (zipmap loop-locals (mapv (comp maybe-class :tag meta) bindings-form))
+ analyze* (fn [ast]
+ (analyze (postwalk ast
+ (fn [ast]
+ (when-let [atom (:atom ast)]
+ (swap! atom dissoc :dirty?))
+ ast))))]
+ (binding [validating loop-id
+ *loop-locals* loop-locals]
+ (analyze* (dissoc (postwalk (assoc ast key
+ (mapv (fn [{:keys [atom] :as bind} f]
+ (if f
+ (do
+ (swap! atom assoc :dirty? true)
+ (assoc (dissoc bind :tag) :form f))
+ bind))
+ (key ast) bindings-form))
+ (comp -cleanup-dirty-nodes
+ (fn [ast] (assoc-in ast [:env :loop-locals-casts] binds))))
+ :dirty?))))
+ ast)))))
+
+(defmethod -validate-loop-locals :loop
+ [analyze ast]
+ (-validate-loop-locals* analyze ast :bindings))
+
+(defmethod -validate-loop-locals :fn-method
+ [analyze ast]
+ (-validate-loop-locals* analyze ast :params))
+
+(defmethod -validate-loop-locals :method
+ [analyze ast]
+ (-validate-loop-locals* analyze ast :params))
+
+(defmethod -validate-loop-locals :recur
+ [_ {:keys [exprs env loop-id] :as ast}]
+ (if (= validating loop-id)
+ (let [casts (:loop-locals-casts env)]
+ (assoc ast
+ :exprs (mapv (fn [{:keys [env form] :as e} n]
+ (if-let [c (casts n)]
+ (assoc e :tag c)
+ e)) exprs *loop-locals*)))
+ ast))
+
+(defmethod -validate-loop-locals :default
+ [_ ast]
+ ast)
+
+(defn validate-loop-locals
+ "Returns a pass that validates the loop locals, calling analyze on the loop AST when
+ a mismatched loop-local is found"
+ {:pass-info {:walk :post :depends #{#'validate} :affects #{#'analyze-host-expr #'infer-tag #'validate} :after #{#'classify-invoke}}}
+ [analyze]
+ (fn [ast] (-validate-loop-locals analyze ast)))
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj
new file mode 100644
index 000000000..3058e456b
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/validate_recur.clj
@@ -0,0 +1,40 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.validate-recur
+ (:require [clojure.tools.analyzer.ast :refer [update-children]]
+ [clojure.tools.analyzer.utils :refer [-source-info]]))
+
+(defmulti validate-recur
+ "Ensures recurs don't cross try boundaries"
+ {:pass-info {:walk :pre :depends #{}}}
+ :op)
+
+(defmethod validate-recur :default [ast]
+ (if (-> ast :env :no-recur)
+ (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true)))
+ ast))
+
+(defmethod validate-recur :try [ast]
+ (update-children ast (fn [ast] (update-in ast [:env] assoc :no-recur true))))
+
+(defmethod validate-recur :fn-method [ast]
+ (update-in ast [:env] dissoc :no-recur))
+
+(defmethod validate-recur :method [ast]
+ (update-in ast [:env] dissoc :no-recur))
+
+(defmethod validate-recur :loop [ast]
+ (update-in ast [:env] dissoc :no-recur))
+
+(defmethod validate-recur :recur [ast]
+ (when (-> ast :env :no-recur)
+ (throw (ex-info "Cannot recur across try"
+ (merge {:form (:form ast)}
+ (-source-info (:form ast) (:env ast))))))
+ ast)
diff --git a/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj
new file mode 100644
index 000000000..8b162e5c2
--- /dev/null
+++ b/tools-analyzer/nextjournal/clerk/clojure/tools/analyzer/passes/jvm/warn_on_reflection.clj
@@ -0,0 +1,62 @@
+;; Copyright (c) Nicola Mometto, Rich Hickey & contributors.
+;; The use and distribution terms for this software are covered by the
+;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;; which can be found in the file epl-v10.html at the root of this distribution.
+;; By using this software in any fashion, you are agreeing to be bound by
+;; the terms of this license.
+;; You must not remove this notice, or any other, from this software.
+
+(ns nextjournal.clerk.clojure.tools.analyzer.passes.jvm.warn-on-reflection
+ (:require [nextjournal.clerk.clojure.tools.analyzer.passes.jvm
+ [validate-loop-locals :refer [validate-loop-locals]]
+ [validate :refer [validate]]]))
+
+(defn warn [what {:keys [file line column]}]
+ (when *warn-on-reflection*
+ (binding [*err* *out*]
+ (println (str "Reflection warning: "
+ (when file
+ (str file ":"))
+ (when line
+ (str line ":"))
+ (when column
+ (str column " "))
+ "- " what)))))
+
+(defmulti warn-on-reflection
+ "Prints a warning to *err* when *warn-on-reflection* is true
+ and a node requires runtime reflection"
+ {:pass-info {:walk :pre :depends #{#'validate} :after #{#'validate-loop-locals}}}
+ :op)
+
+(defmethod warn-on-reflection :instance-call
+ [ast]
+ (when-not (:validated? ast)
+ (warn (str "call to method " (:method ast) (when-let [class (:class ast)]
+ (str " on " (.getName ^Class class)))
+ " cannot be resolved") (:env ast)))
+ ast)
+
+(defmethod warn-on-reflection :static-call
+ [ast]
+ (when-not (:validated? ast)
+ (warn (str "call to static method " (:method ast) " on "
+ (.getName ^Class (:class ast)) " cannot be resolved")
+ (:env ast)))
+ ast)
+
+(defmethod warn-on-reflection :host-interop
+ [ast]
+ (warn (str "reference to field or no args method call " (:m-or-f ast)
+ " cannot be resolved")
+ (:env ast))
+ ast)
+
+(defmethod warn-on-reflection :new
+ [ast]
+ (when-not (:validated? ast)
+ (warn (str "call to " (.getName ^Class (:val (:class ast))) " ctor cannot be resolved")
+ (:env ast)))
+ ast)
+
+(defmethod warn-on-reflection :default [ast] ast)