├── script ├── repl ├── test ├── move-ns.sh └── sync-master.sh ├── images └── part-of-typed-clojure-project.png ├── CHANGELOG.md ├── .gitignore ├── src ├── test │ └── clojure │ │ └── clojure │ │ └── core │ │ └── typed │ │ └── annotator │ │ └── test │ │ ├── rt_infer │ │ ├── loop.clj │ │ ├── anon_lambda.clj │ │ └── vector.clj │ │ ├── runtime_infer │ │ ├── kw_singleton.clj │ │ ├── fixed_varargs.clj │ │ ├── def_name.clj │ │ ├── gen_arglists.clj │ │ ├── bench_track.clj │ │ ├── qualified_keys.clj │ │ └── polymorphic.clj │ │ ├── spec_infer.clj │ │ └── mini_occ.clj └── main │ └── clojure │ └── clojure │ └── core │ └── typed │ └── annotator │ ├── debug_macros.clj │ ├── env.cljc │ ├── rep.cljc │ ├── pprint.cljc │ ├── parse.cljc │ ├── util.cljc │ ├── insert.clj │ ├── join.cljc │ ├── track.cljc │ └── frontend │ └── spec.cljc ├── .github └── workflows │ └── clj.yml ├── deps.edn ├── README.md ├── pom.xml └── epl-v10.html /script/repl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | clj -Atest:nREPL "$@" 4 | -------------------------------------------------------------------------------- /script/test: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | clojure -Atest:runner "$@" 4 | -------------------------------------------------------------------------------- /script/move-ns.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | git grep -l clojure\.core\.typed\.$1 | xargs sed -i '' "s/clojure\.core\.typed\.$1/clojure.core.typed.$2/g" 4 | -------------------------------------------------------------------------------- /images/part-of-typed-clojure-project.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/clojure/core.typed.annotator.jvm/master/images/part-of-typed-clojure-project.png -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # 0.7.0 - 17 November 2018 2 | 3 | - split out `org.clojure/core.typed.annotator.jvm` from core.typed, 4 | replacing `org.clojure/core.typed.infer`. 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | target 2 | *jar 3 | /lib/ 4 | /classes/ 5 | .lein* 6 | *.swp 7 | *.swo 8 | *.aux 9 | *.dvi 10 | *.pdf 11 | *.log 12 | *~ 13 | /.classpath 14 | /.project 15 | /.settings 16 | /bin 17 | .gitignore 18 | .nrepl-port 19 | .repl 20 | .\#* 21 | .idea 22 | **.class 23 | *.iml 24 | .nrepl-port 25 | .DS_Store 26 | .cljs_* 27 | nashorn_* 28 | .cpcache 29 | .rebel_readline_history 30 | junit-output.xml 31 | -------------------------------------------------------------------------------- /script/sync-master.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | branch_name="$(git symbolic-ref HEAD 2>/dev/null)" || 4 | branch_name="(unnamed branch)" # detached HEAD 5 | 6 | branch_name=${branch_name##refs/heads/} 7 | 8 | MASTER="master" 9 | 10 | set -e 11 | 12 | if [ $branch_name != "$MASTER" ]; then 13 | echo "Must be on $MASTER" 14 | exit 1; 15 | fi 16 | 17 | git pull clojure --ff-only master 18 | git pull typedclojure --ff-only master 19 | git push typedclojure master 20 | git push clojure master 21 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/rt_infer/loop.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.rt-infer.loop 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}}} 4 | (:require [clojure.core.typed :as t])) 5 | 6 | (defn b [coll] 7 | (loop [c coll, out []] 8 | (if (seq c) 9 | (recur (next c) (conj out (inc (first c)))) 10 | out))) 11 | 12 | (b [1 2 3 4 5]) 13 | 14 | ;(defn c [coll] 15 | ; (loop [[:as c] coll 16 | ; out [] 17 | ; {:as nothing} {}] 18 | ; (if (seq c) 19 | ; (recur (next c) (conj out (inc (first c))) nil) 20 | ; out))) 21 | ; 22 | ;(c [1 2 3 4 5]) 23 | 24 | (doall 25 | (for 26 | [a [1 2] 27 | b [2 3]] 28 | [a b]) 29 | ) 30 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/kw_singleton.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.kw-singleton 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:require [clojure.core.typed :as t] 6 | [clojure.spec.alpha :as s] 7 | [clojure.pprint :refer [pprint]])) 8 | 9 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 10 | (s/def ::a #{:e :c :b :d :f}) 11 | (s/def ::AMap (s/keys :req [::a])) 12 | (s/fdef single-out :args (s/cat) :ret ::AMap) 13 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 14 | (defn single-out [] 15 | (rand-nth 16 | [{::a :b} 17 | {::a :c} 18 | {::a :d} 19 | {::a :e} 20 | {::a :f}])) 21 | 22 | (dotimes [_ 100] 23 | (single-out)) 24 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/fixed_varargs.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.fixed-varargs 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:require [clojure.core.typed :as t] 6 | [clojure.spec.alpha :as s] 7 | [clojure.pprint :refer [pprint]])) 8 | 9 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 10 | (s/fdef collapse-me :args (s/cat :args (s/* int?)) :ret nil?) 11 | (s/fdef function :args (s/cat :i int? :f int? :j (s/* int?)) :ret int?) 12 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 13 | 14 | (defn function 15 | ([i f] (function i f 0)) 16 | ([i j & [k]] 17 | i)) 18 | 19 | 20 | (function 1 2) 21 | (function 1 2 3) 22 | 23 | (defn collapse-me 24 | ([& args])) 25 | 26 | 27 | (collapse-me 1 2) 28 | (collapse-me 1 2 3) 29 | -------------------------------------------------------------------------------- /.github/workflows/clj.yml: -------------------------------------------------------------------------------- 1 | name: Run tests with clj 2 | 3 | on: [push] 4 | 5 | jobs: 6 | build: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v2 10 | - name: Set up JDK 1.11 11 | uses: actions/setup-java@v1 12 | with: 13 | java-version: 1.11 14 | - uses: DeLaGuardo/setup-clojure@2.0 15 | with: 16 | tools-deps: latest 17 | - name: Run tests 18 | run: ./script/test 19 | #- run: mvn --version 20 | #- run: mvn test 21 | #- run: mvn install -DskipTests=true 22 | #- run: 23 | # command: | 24 | # git clone https://github.com/frenchy64/runtime-type-inference-lein.git ~/runtime-type-inference-lein 25 | #- run: 26 | # command: | 27 | # cd ~/runtime-type-inference-lein 28 | # ./infer-types.sh 29 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/def_name.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.def-name 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:require [clojure.core.typed :as t] 6 | [clojure.pprint :refer [pprint]])) 7 | 8 | (defn game-over-success [game-state] 9 | (reset! game-state {:sector [1 2] 10 | :quadrant [3 2] 11 | :energy 33 12 | :is_docked false 13 | :shields 343}) 14 | (reset! game-state {:extra 1 15 | :sector [1 2] 16 | :quadrant [3 2] 17 | :energy 33 18 | :is_docked false 19 | :shields 343}) 20 | (swap! game-state assoc :is_docked true) 21 | nil) 22 | 23 | (game-over-success (atom {})) 24 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/spec_infer.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.spec-infer 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:refer-clojure :exclude [alias]) 6 | (:require [clojure.core.typed :as t])) 7 | 8 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 9 | (declare alias alias__347185) 10 | (t/defalias alias (t/U t/Sym Long)) 11 | (t/defalias alias__347185 (t/U t/Str Long)) 12 | (t/ann 13 | mapfn 14 | [[alias :-> alias__347185] 15 | (t/U (t/Seqable (t/U t/Sym Long)) (t/Seqable t/Sym) (t/Vec Long)) 16 | :-> 17 | (t/Seqable (t/U t/Str Long))]) 18 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 19 | 20 | (do 21 | (defn mapfn [f c] 22 | (map f c)) 23 | 24 | (mapfn inc [1 2 3]) 25 | (mapfn inc '(1 2 3)) 26 | (mapfn str '(a b c)) 27 | ) 28 | 29 | #_ 30 | (do 31 | (defn sym 32 | ([name] (symbol name)) 33 | ([ns name] (symbol ns name))) 34 | 35 | (sym "a") 36 | (sym 'a) 37 | (sym "abc" "bcd") 38 | (sym nil "bcd") 39 | ) 40 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/rt_infer/anon_lambda.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.rt-infer.anon-lambda 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}}} 4 | (:require [clojure.core.typed :as t])) 5 | 6 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 7 | (declare) 8 | (t/ann b [(t/Vec Long) :-> (t/Coll Long)]) 9 | (t/ann c [Long :-> Long]) 10 | (t/ann d [Long :-> Long]) 11 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 12 | (defmacro hidden-f [& args] 13 | `(fn ~@args)) 14 | 15 | (defn b [coll] 16 | (->> coll 17 | (map 18 | (t/ann-form 19 | (fn [n] (inc n)) 20 | [Long :-> Long]) 21 | ) ;; hello 22 | (filter 23 | (t/ann-form 24 | (fn [n] (odd? n)) 25 | [Long :-> (t/U Boolean false)]) 26 | ))) 27 | 28 | (b [1 2 3 4 5]) 29 | 30 | ;(defn c [n] 31 | ; ((hidden-f [a] (inc a)) 32 | ; n)) 33 | ; 34 | ;(c 1) 35 | 36 | (defn d [n] 37 | (#(inc ^{::t/ann Long} %) n)) 38 | 39 | (d 1) 40 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/gen_arglists.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.gen-arglists 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:refer-clojure :exclude [*]) 6 | (:require [clojure.core.typed :as t] 7 | [clojure.core :as core] 8 | [clojure.spec.alpha :as s] 9 | [clojure.pprint :refer [pprint]])) 10 | 11 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 12 | (s/fdef * :args (s/cat :x int? :xs-0 int?) :ret int?) 13 | (s/fdef 14 | function 15 | :args 16 | (s/alt :1-arg (s/cat :a int?) :2-args (s/cat :a int? :b-0 int?)) 17 | :ret 18 | int?) 19 | (s/fdef 20 | function2 21 | :args 22 | (s/alt :1-arg (s/cat :a int?) :2-args (s/cat :a int? :b-0 int?)) 23 | :ret 24 | int?) 25 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 26 | (def function 27 | (fn 28 | ([a] a) 29 | ([a & b] a))) 30 | 31 | (def * 32 | (fn 33 | ([] 1) 34 | ([x] x) 35 | ([x & xs] 36 | (reduce (fnil core/* 0M 0M) x xs)))) 37 | 38 | (def function2 function) 39 | 40 | (function 1) 41 | (function 1 2) 42 | 43 | (function2 1 2) 44 | (function2 1) 45 | 46 | (* 2 3) 47 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/debug_macros.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.debug-macros 2 | (:require [clojure.core.typed.annotator.util :refer [*debug* 3 | *debug-depth* 4 | current-time]]) 5 | ) 6 | 7 | (defmacro debug-flat 8 | ([msg] 9 | `(when (= :all *debug*) 10 | (print (str (apply str (repeat *debug-depth* " ")) *debug-depth* ": ")) 11 | ~msg))) 12 | 13 | (defmacro debug 14 | ([msg body] 15 | `(do 16 | (debug-flat ~msg) 17 | (binding [*debug-depth* (when (= :all *debug*) 18 | (inc *debug-depth*))] 19 | ~body)))) 20 | 21 | (defmacro debug-when [state msg] 22 | `(when (and (set? *debug*) 23 | (contains? *debug* ~state)) 24 | (let [msg# ~msg] 25 | (println) 26 | (println (str "SQUASH ITERATION:\n" msg#))))) 27 | 28 | (defmacro debug-squash [msg] 29 | `(debug-when :squash 30 | (str "\nSQUASH ITERATION:\n" ~msg "\n"))) 31 | 32 | (defmacro time-if-slow 33 | "Evaluates expr and prints the time it took. Returns the value of expr." 34 | [msg expr] 35 | `(let [start# (current-time) 36 | ret# ~expr 37 | msduration# (/ (double (- (current-time) start#)) 1000000.0)] 38 | (when (< 1000 msduration#) 39 | (prn (str "Elapsed time: " msduration# " msecs")) 40 | (prn ~msg)) 41 | ret#)) 42 | 43 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/rt_infer/vector.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.rt-infer.vector 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}}} 4 | (:require [clojure.core.typed :as t])) 5 | 6 | (defn b [coll] 7 | (if (< 0.5 (rand)) 8 | [1 2 3] 9 | [1 2 3 4])) 10 | 11 | (defn nilable [coll] 12 | (if (< 0.5 (rand)) 13 | nil 14 | coll)) 15 | 16 | (dotimes [_ 10] 17 | (b (vec (repeat (int (* 10 (rand) )) 10))) 18 | (nilable (vec (repeat (int (* 10 (rand) )) 10)))) 19 | 20 | (defn cartesian-product 21 | "All the ways to take one item from each sequence" 22 | [& seqs] 23 | (let [v-original-seqs (vec seqs) 24 | step (fn step [v-seqs] 25 | (let [increment 26 | (fn [v-seqs] 27 | (loop [i (dec (count v-seqs)), v-seqs v-seqs] 28 | (if (= i -1) nil 29 | (if-let [rst (next (v-seqs i))] 30 | (assoc v-seqs i rst) 31 | (recur (dec i) (assoc v-seqs i (v-original-seqs i)))))))] 32 | (when v-seqs 33 | (cons (map first v-seqs) 34 | (lazy-seq (step (increment v-seqs)))))))] 35 | (when (every? seq seqs) 36 | (lazy-seq (step v-original-seqs))))) 37 | 38 | (defn selections 39 | "All the ways of taking n (possibly the same) elements from the sequence of items" 40 | [items n] 41 | (apply cartesian-product (take n (repeat items)))) 42 | 43 | (cartesian-product [1 2] [3 4]) 44 | (cartesian-product [1 2 3] [3 4 5]) 45 | (selections [1 2] 3) 46 | (selections [1 2 3] 3) 47 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/env.cljc: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.env 10 | ) 11 | 12 | (defn initial-results 13 | ([] (initial-results nil [])) 14 | ([parent base] 15 | {:infer-results #{} 16 | :equivs [] 17 | ;; TODO 18 | :path-occ {}})) 19 | 20 | (defn infer-results? [m] 21 | (and (map? m) 22 | (-> m :infer-results set?) 23 | (-> m :path-occ map?) 24 | (-> m :equivs vector?))) 25 | 26 | ; results-atom : (Atom InferResultEnv) 27 | (def results-atom (atom (initial-results) :validator infer-results?)) 28 | 29 | (defn add-infer-results! [results-atom r] 30 | (swap! results-atom 31 | (fn [m] 32 | (-> m 33 | (update :root-results 34 | (fn [root-results] 35 | (reduce (fn [root-results nme] 36 | (if (symbol? nme) 37 | (update root-results nme (fnil inc 1)) 38 | root-results)) 39 | root-results 40 | (map (comp :name #(nth % 0) :path) r)))) 41 | (update :infer-results #(into (or % #{}) r)))))) 42 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/bench_track.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.bench-track 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:require [clojure.core.typed :as t] 6 | [clojure.spec.alpha :as s] 7 | [clojure.test :refer :all] 8 | [clojure.walk :as walk] 9 | [clojure.pprint :refer [pprint]])) 10 | 11 | (defn stack-depth [i] 12 | (if (zero? i) 13 | nil 14 | (stack-depth (dec i)))) 15 | 16 | (defn no-rewrap-f [i f] 17 | (if (zero? i) 18 | f 19 | (no-rewrap-f (dec i) f))) 20 | 21 | (defn traverse-map-once [i m] 22 | (if (zero? i) 23 | (:a m) 24 | (traverse-map-once (dec i) m))) 25 | 26 | (defn call-if-zero [i f] 27 | (if (= 0 i) 28 | (f) 29 | (call-if-zero (dec i) f))) 30 | 31 | (comment 32 | (defmacro bench 33 | "Evaluates expr and returns the time it took." 34 | [expr] 35 | `(let [start# (. System (nanoTime)) 36 | ret# ~expr 37 | msduration# (/ (double (- (. System (nanoTime)) start#)) 1000000.0)] 38 | [ret# msduration#])) 39 | 40 | (defn bench-iteratively 41 | ([f n] (bench-iteratively f 0 n)) 42 | ([f start n] 43 | (loop [times [] 44 | i start] 45 | (if (< n i) 46 | times 47 | (let [[_ t] (f i)] 48 | (recur (conj times t) 49 | (inc i))))))) 50 | 51 | (defn write-csv [n v] 52 | {:pre [(vector? v)]} 53 | (spit n (apply str (interpose "," v)))) 54 | 55 | ;; tracking overhead? 56 | (write-csv 57 | "no-track-stack-depth.csv" 58 | (bench-iteratively 59 | (bench (stack-depth i)))) 60 | 61 | (stack-depth 1000) 62 | (traverse-map-once 63 | 3000 64 | {:a 1}) 65 | 66 | (call-if-zero 1000 (fn [] (prn "called"))) 67 | ) 68 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src/main/clojure"] 2 | :deps {org.clojure/core.typed.runtime.jvm {:mvn/version "0.7.1-SNAPSHOT"} 3 | org.clojure/core.typed.analyzer.jvm {:mvn/version "0.7.1"} 4 | org.clojure/tools.reader {:mvn/version "1.1.1"} 5 | org.clojure/tools.namespace {:mvn/version "0.3.0-alpha4"} 6 | org.clojure/math.combinatorics {:mvn/version "0.1.4" 7 | :exclusions [org.clojure/clojure]} 8 | org.clojure/tools.analyzer.jvm {:mvn/version "0.7.0"} 9 | ;; can't vendor this as it includes Java sources that need to be compiled. 10 | ;; perhaps we can make it optional in the future. 11 | potemkin {:mvn/version "0.4.5"}} 12 | :mvn/repos {"sonatype-oss-public" {:url "https://oss.sonatype.org/content/groups/public/"}} 13 | :aliases {:test 14 | {:extra-paths ["src/test/clojure"] 15 | :extra-deps {org.clojure/test.check {:mvn/version "0.9.0" 16 | :scope "test"} 17 | com.gfredericks/test.chuck {:mvn/version "0.2.6" 18 | :scope "test"}}} 19 | :script {:extra-paths ["script"]} 20 | :nREPL 21 | {:extra-deps 22 | {nrepl/nrepl {:mvn/version "0.4.5"} 23 | cider/piggieback {:mvn/version "0.3.8"}} 24 | :main-opts ["-m" "nrepl.cmdline" 25 | "--interactive"]} 26 | :runner 27 | {:extra-deps {com.cognitect/test-runner 28 | {:git/url "https://github.com/cognitect-labs/test-runner" 29 | :sha "3cb0a9daf1cb746259dc8309b218f9211ad3b33b"}} 30 | :main-opts ["-m" "cognitect.test-runner" 31 | "-d" "src/test/clojure" 32 | "-r" ".*"]}}} 33 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # core.typed.annotator.jvm 2 | 3 | 4 | 5 | Automatic annotator for Typed Clojure and clojure.spec annotations, for JVM Clojure. 6 | 7 | ## DEPRECATION NOTICE 8 | 9 | This repository is DEPRECATED and development has been moved 10 | to the [core.typed](https://github.com/clojure/core.typed) monorepo. 11 | Please follow [these](https://github.com/clojure/core.typed/blob/master/UPGRADING.md#upgrading-from-07x-to-monorepo) 12 | instructions to upgrade. 13 | 14 | ## Releases and Dependency Information 15 | 16 | Latest stable release is 0.7.0. 17 | 18 | * [All Released Versions](https://search.maven.org/search?q=g:org.clojure%20AND%20a:core.typed.annotator.jvm) 19 | 20 | [deps.edn](https://clojure.org/reference/deps_and_cli) dependency information: 21 | 22 | ```clj 23 | org.clojure/core.typed.annotator.jvm {:mvn/version "0.7.0"} 24 | ``` 25 | 26 | [Leiningen](https://github.com/technomancy/leiningen) dependency information: 27 | 28 | ```clojure 29 | [org.clojure/core.typed.annotator.jvm "0.7.0"] 30 | ``` 31 | 32 | [Maven](https://maven.apache.org/) dependency information: 33 | 34 | ```XML 35 | 36 | org.clojure 37 | core.typed.annotator.jvm 38 | 0.7.0 39 | 40 | ``` 41 | 42 | ## YourKit 43 | 44 | YourKit is kindly supporting core.typed and other open source projects with its full-featured Java Profiler. 45 | YourKit, LLC is the creator of innovative and intelligent tools for profiling 46 | Java and .NET applications. Take a look at YourKit's leading software products: 47 | 48 | * YourKit Java Profiler and 49 | * YourKit .NET Profiler. 50 | 51 | ## License 52 | 53 | Copyright © Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 54 | 55 | Licensed under the EPL (see the file epl-v10.html). 56 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/qualified_keys.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.qualified-keys 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:require [clojure.core.typed :as t] 6 | [clojure.spec.alpha :as s] 7 | [clojure.test :refer :all] 8 | [clojure.walk :as walk] 9 | [clojure.pprint :refer [pprint]])) 10 | 11 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 12 | (defmulti op-multi-spec :op) 13 | (defmethod op-multi-spec :fn [_] (s/keys :req-un [::context ::fn ::op])) 14 | (defmethod 15 | op-multi-spec 16 | :lambda 17 | [_] 18 | (s/keys :req-un [::body ::context ::op])) 19 | (defmethod 20 | op-multi-spec 21 | :val 22 | [_] 23 | (s/keys :req-un [::op ::val] :opt-un [::context])) 24 | (s/def ::val any?) 25 | (s/def ::context any?) 26 | (s/def ::op any?) 27 | (s/def ::body any?) 28 | (s/def ::fn any?) 29 | (s/def ::Op (s/multi-spec op-multi-spec :op)) 30 | (s/fdef op-unq :args (s/cat) :ret ::Op) 31 | (s/fdef single :args (s/cat) :ret any?) 32 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 33 | (defn unqualified [] 34 | {:foo {:foo {:foo nil}}} 35 | ) 36 | (defn qualified [] 37 | {::foo {::foo {::foo nil}}} 38 | ) 39 | 40 | (defn qualified2 [] 41 | (rand-nth 42 | [{::foo2 {::foo nil}} 43 | {::foo2 {::foo {::foo1 :a}}} 44 | {::foo2 {::foo {::foo1 :b}}} 45 | {::foo2 {::foo {::foo1 :c}}} 46 | ]) 47 | ) 48 | 49 | (defn same1 [] 50 | {:blah 1 51 | :flag 2 52 | :opt1 2 53 | :opt2 3}) 54 | 55 | (defn same2 [] 56 | {:blah 1 57 | :flag 2 58 | :opt1 2 59 | :opt3 3}) 60 | 61 | (defn single [] 62 | {:a 1}) 63 | 64 | (defn op-unq [] 65 | (rand-nth 66 | [{:op :fn 67 | :context :expression 68 | :fn {:op :lambda 69 | :context :statement 70 | :body {:op :val 71 | :context :statement 72 | :val 1}}} 73 | {:op :val 74 | :val 1} 75 | ]) 76 | ) 77 | 78 | ;(qualified) 79 | ;(doall (repeatedly 100 qualified2)) 80 | ;(unqualified) 81 | ;(same1) 82 | ;(same2) 83 | (single) 84 | (doall (repeatedly 100 (comp #(walk/postwalk identity %) op-unq))) 85 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/runtime_infer/polymorphic.clj: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.test.runtime-infer.polymorphic 2 | {:lang :core.typed 3 | :core.typed {:features #{:runtime-infer}} 4 | } 5 | (:refer-clojure :exclude [identity memoize]) 6 | (:require [clojure.core.typed :as t] 7 | [clojure.core :as core] 8 | [clojure.spec.alpha :as s] 9 | [clojure.pprint :refer [pprint]])) 10 | 11 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 12 | (declare AMap) 13 | (t/defalias AMap '{:a (t/U t/Int t/Sym)}) 14 | (t/ann 15 | get-a 16 | [(t/U AMap (t/Map t/Nothing t/Nothing)) :-> (t/U nil t/Int t/Sym)]) 17 | (comment (t/ann get-a (t/All [x] ['{:a x} :-> x]))) 18 | (comment (t/ann get-a (t/All [x] ['{:a x} :-> x]))) 19 | (t/ann identity [t/Int :-> t/Int]) 20 | (comment (t/ann identity (t/All [x] [x :-> x]))) 21 | (comment (t/ann identity (t/All [x] [x :-> x]))) 22 | (t/ann memoize AnyFunction) 23 | (t/ann 24 | mymap 25 | [[(t/U t/Int t/Sym) :-> (t/U t/Str t/Int)] 26 | (t/Vec (t/U t/Int t/Sym)) 27 | :-> 28 | (t/Coll (t/U t/Str t/Int))]) 29 | (comment (t/ann mymap (t/All [x] [[x :-> ?] (t/Vec x) :-> ?]))) 30 | (comment (t/ann mymap (t/All [x] [[x :-> ?] '[? ? x] :-> ?]))) 31 | (comment (t/ann mymap (t/All [x] [[? :-> x] ? :-> (t/Coll x)]))) 32 | (comment (t/ann mymap (t/All [x] [[x :-> ?] '[x ? ?] :-> ?]))) 33 | (comment (t/ann mymap (t/All [x] [[x :-> ?] '[? x ?] :-> ?]))) 34 | (comment (t/ann mymap (t/All [x] [[? :-> x] ? :-> (t/Coll x)]))) 35 | (comment (t/ann mymap (t/All [x] [[x :-> ?] '[x] :-> ?]))) 36 | (t/ann plus1 [t/Int :-> t/Int]) 37 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 38 | (s/def identity ifn?) 39 | 40 | (defn identity [x] 41 | x) 42 | 43 | (defn plus1 [x] 44 | (inc x)) 45 | 46 | (defn memoize [f] 47 | (fn [a] 48 | (f a))) 49 | 50 | (defn mymap [f c] 51 | (map f c)) 52 | 53 | (defn get-a [m] 54 | (:a m)) 55 | 56 | (identity 1) 57 | ;(identity 'a) 58 | ;(identity :a) 59 | 60 | ;(memoize identity) 61 | ;((memoize identity) 1) 62 | ;(identity 1) 63 | ;(identity 2) 64 | 65 | ;((memoize plus1) 1) 66 | 67 | (mymap plus1 [1]) 68 | (mymap name ['a 'b 'c]) 69 | 70 | (get-a {:a 1}) 71 | (get-a {:a 'a}) 72 | (get-a {}) 73 | (get-a {}) 74 | 75 | ; 76 | ;((memoize identity) 'a) 77 | ;((nth (iterate memoize identity) 100) :a) 78 | -------------------------------------------------------------------------------- /pom.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4.0.0 4 | org.clojure 5 | core.typed.annotator.jvm 6 | 0.7.1-SNAPSHOT 7 | Runtime type inference algorithm for core.typed and clojure.spec. 8 | core.typed.annotator.jvm 9 | 10 | 11 | 12 | Eclipse Public License 1.0 13 | http://opensource.org/licenses/eclipse-1.0.php 14 | repo 15 | 16 | 17 | 18 | 19 | org.clojure 20 | pom.contrib 21 | 0.3.0 22 | 23 | 24 | 25 | 26 | sonatype-oss-public 27 | https://oss.sonatype.org/content/groups/public/ 28 | 29 | 30 | clojars.org 31 | https://clojars.org/repo 32 | 33 | 34 | 35 | 36 | 37 | 38 | com.theoryinpractise 39 | clojure-maven-plugin 40 | 1.7.1 41 | 42 | 43 | clojure-compile 44 | none 45 | 46 | 47 | clojure-test 48 | test 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | org.clojure 58 | clojure 59 | 1.9.0 60 | 61 | 62 | org.clojure 63 | core.typed.runtime.jvm 64 | 0.7.1-SNAPSHOT 65 | 66 | 67 | org.clojure 68 | core.typed.analyzer.jvm 69 | 0.7.1 70 | 71 | 72 | org.clojure 73 | tools.reader 74 | 1.1.1 75 | 76 | 77 | org.clojure 78 | tools.namespace 79 | 0.3.0-alpha4 80 | 81 | 82 | org.clojure 83 | math.combinatorics 84 | 0.1.4 85 | 86 | 87 | org.clojure 88 | clojure 89 | 90 | 91 | 92 | 93 | org.clojure 94 | tools.analyzer.jvm 95 | 0.7.0 96 | 97 | 98 | potemkin 99 | potemkin 100 | 0.4.5 101 | 102 | 103 | org.clojure 104 | test.check 105 | 0.9.0 106 | test 107 | 108 | 109 | com.gfredericks 110 | test.chuck 111 | 0.2.6 112 | test 113 | 114 | 115 | 116 | 117 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/rep.cljc: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.rep 10 | "Intermediate representation for types" 11 | ; Note: clojure.core.typed.annotator.util depends on this ns 12 | ) 13 | 14 | ;;======================== 15 | ;;Type Predicates 16 | ;;======================== 17 | 18 | (defn type? [t] 19 | (and (map? t) 20 | (keyword? (:op t)))) 21 | 22 | (defn alias? [t] 23 | (= :alias (:op t))) 24 | 25 | (defn HMap? [t] 26 | (= :HMap (:op t))) 27 | 28 | (defn HVec? [t] 29 | (= :HVec (:op t))) 30 | 31 | (defn union? [t] 32 | (= :union (:op t))) 33 | 34 | (defn Any? [m] 35 | {:pre [(map? m)] 36 | :post [(boolean? %)]} 37 | (= :Top (:op m))) 38 | 39 | (defn unknown? [m] 40 | (= :unknown 41 | (:op m))) 42 | 43 | (defn nothing? [t] 44 | (boolean 45 | (when (union? t) 46 | (empty? (:types t))))) 47 | 48 | (def val? (comp boolean #{:val} :op)) 49 | 50 | ;;======================== 51 | ;;Type Constructors 52 | ;;======================== 53 | 54 | (defn -class? [m] 55 | (boolean (#{:class} (:op m)))) 56 | 57 | (defn -alias [name] 58 | {:pre [(symbol? name)]} 59 | {:op :alias 60 | :name name}) 61 | 62 | (def -any {:op :Top}) 63 | 64 | (def -nothing {:op :union :types #{}}) 65 | 66 | (defn -val [v] 67 | {:op :val 68 | :val v}) 69 | 70 | (defn -class [cls args] 71 | {:pre [(vector? args) 72 | (every? type? args)]} 73 | (assert ((some-fn keyword? string?) cls) cls) 74 | {:op :class 75 | :clojure.core.typed.annotator.rep/class-instance cls 76 | :args args}) 77 | 78 | (defn make-HMap [req opt] 79 | {:op :HMap 80 | :clojure.core.typed.annotator.rep/HMap-req req 81 | :clojure.core.typed.annotator.rep/HMap-opt opt}) 82 | 83 | ;;======================== 84 | ;; Inference results 85 | ;;======================== 86 | 87 | (defn infer-result [path type] 88 | {:op :path-type 89 | :type type 90 | :path path}) 91 | 92 | (defn infer-results [paths type] 93 | (map #(infer-result % type) paths)) 94 | 95 | ;; ======================== 96 | ;; Path elements 97 | ;; ======================== 98 | 99 | (defn key-path 100 | ([keys key] (key-path {} keys key)) 101 | ([kw-entries keys key] 102 | {:pre [(keyword? key)]} 103 | {:op :key 104 | ;; (Map Kw (ValType Kw)) for constant keyword entries 105 | :kw-entries kw-entries 106 | :keys keys 107 | :key key})) 108 | 109 | (defn map-keys-path [] 110 | {:op :map-keys}) 111 | 112 | (defn map-vals-path [] 113 | {:op :map-vals}) 114 | 115 | ;; for zero arity, use (fn-dom-path 0 -1) 116 | (defn fn-dom-path [arity pos] 117 | (assert (< pos arity) 118 | (str "Arity: " arity 119 | "Position:" pos)) 120 | {:op :fn-domain 121 | :arity arity :position pos}) 122 | 123 | (defn fn-rng-path [arity] 124 | {:op :fn-range 125 | :arity arity}) 126 | 127 | (defn seq-entry [] 128 | {:op :seq-entry}) 129 | 130 | (defn transient-vector-entry [] 131 | {:op :transient-vector-entry}) 132 | 133 | (defn index-path [count nth] 134 | {:op :index 135 | :count count 136 | :nth nth}) 137 | 138 | (defn vec-entry-path [] 139 | {:op :vec-entry}) 140 | 141 | (defn set-entry [] 142 | {:op :set-entry}) 143 | 144 | (defn atom-contents [] 145 | {:op :atom-contents}) 146 | 147 | (defn var-path 148 | ([name] (var-path nil name)) 149 | ([ns name] 150 | {:pre [((some-fn symbol? nil?) ns) 151 | (symbol? name)]} 152 | {:op :var 153 | :ns ns 154 | :name name})) 155 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/pprint.cljc: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.pprint 10 | (:require [#?(:clj clojure.pprint :cljs cljs.pprint) :as pp] 11 | [clojure.core.typed.annotator.util :refer [current-ns unp]])) 12 | 13 | ;; copied from cljs.pprint 14 | #?(:cljs 15 | (defn- pp-type-dispatcher [obj] 16 | (cond 17 | (instance? PersistentQueue obj) :queue 18 | (satisfies? IDeref obj) :deref 19 | (symbol? obj) :symbol 20 | (keyword? obj) :keyword 21 | (seq? obj) :list 22 | (map? obj) :map 23 | (vector? obj) :vector 24 | (set? obj) :set 25 | (nil? obj) nil 26 | :default :default))) 27 | 28 | (defmulti wrap-dispatch 29 | "A wrapper for code dispatch that prints local keywords with ::" 30 | {:arglists '[[object]]} 31 | #?(:clj class 32 | :cljs pp-type-dispatcher)) 33 | 34 | (defmethod wrap-dispatch :default 35 | [o] 36 | (pp/code-dispatch o)) 37 | 38 | ;;; (def pprint-map (formatter-out "~<{~;~@{~<~w~^ ~_~w~:>~^, ~_~}~;}~:>")) 39 | #?(:clj 40 | ;FIXME is this copy-pasted? it's since been updated in clojure.pprint 41 | (defn- pprint-map [amap] 42 | (pp/pprint-logical-block :prefix "{" :suffix "}" 43 | (pp/print-length-loop [aseq (seq amap)] 44 | (when aseq 45 | (pp/pprint-logical-block 46 | (pp/write-out (ffirst aseq)) 47 | (.write ^java.io.Writer *out* " ") 48 | (pp/pprint-newline :linear) 49 | (.set #'pp/*current-length* 0) ; always print both parts of the [k v] pair 50 | (pp/write-out (fnext (first aseq)))) 51 | (when (next aseq) 52 | (.write ^java.io.Writer *out* ", ") 53 | (pp/pprint-newline :linear) 54 | (recur (next aseq)))))))) 55 | 56 | ;; deterministic printing of HMaps 57 | ;;FIXME this doesn't work in CLJS, {:a 1} pprints as: 58 | ;; :a{ 1} 59 | #?(:clj 60 | (defmethod wrap-dispatch #?(:clj clojure.lang.IPersistentMap 61 | :cljs :map) 62 | [o] 63 | (let [{tagged true untagged false} 64 | (group-by (fn [[k v]] 65 | (and (seq? v) 66 | (= 'quote (first v)) 67 | (keyword? (second v)))) 68 | o) 69 | tagged (sort-by first tagged) 70 | untagged (sort-by first untagged) 71 | ordered 72 | (apply array-map 73 | (concat 74 | (mapcat identity tagged) 75 | (mapcat identity untagged)))] 76 | #?(:clj (pprint-map ordered) 77 | :cljs (pp/code-dispatch ordered))))) 78 | 79 | (defmethod wrap-dispatch #?(:clj clojure.lang.Keyword 80 | :cljs :keyword) 81 | [kw] 82 | (let [aliases #?(:clj (ns-aliases (current-ns)) 83 | :cljs #{}) 84 | some-alias (delay 85 | (some (fn [[k v]] 86 | (when (= (namespace kw) 87 | (str (ns-name v))) 88 | k)) 89 | aliases))] 90 | (cond 91 | (= (name (current-ns)) (namespace kw)) 92 | (print (str "::" (name kw))) 93 | 94 | @some-alias 95 | (print (str "::" @some-alias "/" (name kw))) 96 | 97 | :else 98 | (print kw)))) 99 | 100 | (defn pprint [& args] 101 | (pp/with-pprint-dispatch wrap-dispatch 102 | (apply pp/pprint args))) 103 | 104 | (defn pprint-str-no-line [& args] 105 | (binding [pp/*print-right-margin* nil] 106 | ;; remove trailing newline 107 | (let [s (with-out-str 108 | (apply pprint args))] 109 | (subs s 0 (dec (count s)))))) 110 | 111 | (defn unp-str [t] 112 | (let [^String s 113 | (with-out-str 114 | (binding [pp/*print-right-margin* nil] 115 | (pprint (unp t))))] 116 | (.replaceAll s "\\n" ""))) 117 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/parse.cljc: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.parse 10 | (:require [clojure.core.typed.annotator.rep :as r 11 | :refer [-any -class -nothing -alias make-HMap]] 12 | [clojure.core.typed.annotator.util 13 | :refer [alias-env *envs*]] 14 | [clojure.core.typed.annotator.join 15 | :refer [make-Union]])) 16 | 17 | (def ^:dynamic *type-var-scope* #{}) 18 | 19 | (declare parse-type) 20 | 21 | (defn parse-HVec [v] 22 | {:op :HVec 23 | :vec (mapv parse-type v)}) 24 | 25 | (defn parse-literal-HMap [m] 26 | {:op :HMap 27 | :clojure.core.typed.annotator.rep/HMap-req 28 | (into {} 29 | (map (fn [[k v]] 30 | [k (parse-type v)])) 31 | m) 32 | :clojure.core.typed.annotator.rep/HMap-opt {}}) 33 | 34 | (defn parse-HMap [[_ & {:keys [mandatory optional]}]] 35 | (let [prs-map (fn [m] 36 | (into {} 37 | (map (fn [[k v]] 38 | [k (parse-type v)])) 39 | m))] 40 | (make-HMap (prs-map mandatory) 41 | (prs-map optional)))) 42 | 43 | (defn parse-arity [a] 44 | (let [[doms [_->_ rng :as rng-arrow]] (split-with (complement #{:->}) a) 45 | [doms [_ rst :as has-rst]] (split-with (complement #{'&}) doms) 46 | _ (assert (#{0 2} (count has-rst))) 47 | _ (assert (= 2 (count rng-arrow)))] 48 | {:op :IFn1 49 | :dom (mapv parse-type doms) 50 | :rng (parse-type rng) 51 | :rest (when (seq has-rst) 52 | (parse-type rst))})) 53 | 54 | (defn parse-type [m] 55 | (cond 56 | (#{'Any 'clojure.core.typed/Any} m) -any 57 | (= '? m) {:op :unknown} 58 | 59 | (or (= nil m) 60 | (= false m) 61 | (keyword? m)) {:op :val :val m} 62 | 63 | (vector? m) {:op :IFn 64 | :arities [(parse-arity m)]} 65 | 66 | (symbol? m) (case m 67 | (clojure.core.typed/Nothing Nothing) -nothing 68 | (clojure.core.typed/Sym Sym) (-class :symbol []) 69 | (Integer Long 70 | java.lang.Long java.lang.Integer) (-class :int []) 71 | (String java.lang.String) (-class :string []) 72 | (Boolean) (-class :boolean []) 73 | (Double) (-class :double []) 74 | (Number clojure.lang.Number) (-class :number []) 75 | (clojure.lang.IFn) (-class :ifn []) 76 | (clojure.lang.Symbol Symbol) (-class :symbol []) 77 | (cond 78 | (contains? *type-var-scope* m) 79 | {:op :var 80 | :name m} 81 | 82 | (contains? (alias-env @*envs*) m) 83 | (-alias m) 84 | 85 | :else 86 | (throw (ex-info (str "No resolution for " m) {})))) 87 | (seq? m) (case (first m) 88 | All (let [[vs t :as rst] (second m) 89 | _ (assert (= 2 (count rst)))] 90 | {:op :poly 91 | :known-params (into [] 92 | (map (fn [m] 93 | {:pre [(symbol? m)]} 94 | m)) 95 | vs) 96 | :params {} 97 | :type (binding [*type-var-scope* (into *type-var-scope* vs)] 98 | (parse-type t))}) 99 | quote (let [in (second m)] 100 | (cond 101 | (vector? in) (parse-HVec in) 102 | (map? in) (parse-literal-HMap in) 103 | (keyword? in) {:op :val :val in} 104 | :else (assert nil (str "Bad quote: " m)))) 105 | 106 | IFn {:op :IFn 107 | :arities (mapv parse-arity (rest m))} 108 | U (make-Union 109 | (into #{} 110 | (map parse-type) 111 | (rest m))) 112 | HMap (parse-HMap m) 113 | Vec (-class :vector 114 | [(parse-type (second m))]) 115 | (Seqable clojure.lang.Seqable) (-class :seqable 116 | [(parse-type (second m))]) 117 | (PersistentHashSet clojure.lang.PersistentHashSet 118 | IPersistentSet 119 | clojure.lang.IPersistentSet) 120 | (-class :set [(parse-type (second m))]) 121 | (clojure.core.typed/Map 122 | IPersistentMap 123 | clojure.lang.IPersistentMap) (let [[_ k v] m] 124 | (-class :map 125 | [(parse-type k) 126 | (parse-type v)])) 127 | Set (-class :set 128 | [(parse-type (second m))]) 129 | #?(:clj 130 | (let [res (resolve (first m))] 131 | (assert nil (str "TODO no more classes in :class" res)) 132 | (cond ;(contains? (alias-env @*envs*) (:name (first m))) 133 | ;(-alias (first m)) 134 | 135 | (class? res) (-class res (mapv parse-type (drop 1 m))) 136 | 137 | :else (assert nil (str "What is this?" m)))))) 138 | 139 | 140 | :else (assert nil (str "bad type " m)))) 141 | 142 | #?(:clj 143 | (defmacro prs [t] 144 | `(parse-type '~t))) 145 | -------------------------------------------------------------------------------- /epl-v10.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Eclipse Public License - Version 1.0 8 | 25 | 26 | 27 | 28 | 29 | 30 |

Eclipse Public License - v 1.0

31 | 32 |

THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE 33 | PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS 35 | AGREEMENT.

36 | 37 |

1. DEFINITIONS

38 | 39 |

"Contribution" means:

40 | 41 |

a) in the case of the initial Contributor, the initial 42 | code and documentation distributed under this Agreement, and

43 |

b) in the case of each subsequent Contributor:

44 |

i) changes to the Program, and

45 |

ii) additions to the Program;

46 |

where such changes and/or additions to the Program 47 | originate from and are distributed by that particular Contributor. A 48 | Contribution 'originates' from a Contributor if it was added to the 49 | Program by such Contributor itself or anyone acting on such 50 | Contributor's behalf. Contributions do not include additions to the 51 | Program which: (i) are separate modules of software distributed in 52 | conjunction with the Program under their own license agreement, and (ii) 53 | are not derivative works of the Program.

54 | 55 |

"Contributor" means any person or entity that distributes 56 | the Program.

57 | 58 |

"Licensed Patents" mean patent claims licensable by a 59 | Contributor which are necessarily infringed by the use or sale of its 60 | Contribution alone or when combined with the Program.

61 | 62 |

"Program" means the Contributions distributed in accordance 63 | with this Agreement.

64 | 65 |

"Recipient" means anyone who receives the Program under 66 | this Agreement, including all Contributors.

67 | 68 |

2. GRANT OF RIGHTS

69 | 70 |

a) Subject to the terms of this Agreement, each 71 | Contributor hereby grants Recipient a non-exclusive, worldwide, 72 | royalty-free copyright license to reproduce, prepare derivative works 73 | of, publicly display, publicly perform, distribute and sublicense the 74 | Contribution of such Contributor, if any, and such derivative works, in 75 | source code and object code form.

76 | 77 |

b) Subject to the terms of this Agreement, each 78 | Contributor hereby grants Recipient a non-exclusive, worldwide, 79 | royalty-free patent license under Licensed Patents to make, use, sell, 80 | offer to sell, import and otherwise transfer the Contribution of such 81 | Contributor, if any, in source code and object code form. This patent 82 | license shall apply to the combination of the Contribution and the 83 | Program if, at the time the Contribution is added by the Contributor, 84 | such addition of the Contribution causes such combination to be covered 85 | by the Licensed Patents. The patent license shall not apply to any other 86 | combinations which include the Contribution. No hardware per se is 87 | licensed hereunder.

88 | 89 |

c) Recipient understands that although each Contributor 90 | grants the licenses to its Contributions set forth herein, no assurances 91 | are provided by any Contributor that the Program does not infringe the 92 | patent or other intellectual property rights of any other entity. Each 93 | Contributor disclaims any liability to Recipient for claims brought by 94 | any other entity based on infringement of intellectual property rights 95 | or otherwise. As a condition to exercising the rights and licenses 96 | granted hereunder, each Recipient hereby assumes sole responsibility to 97 | secure any other intellectual property rights needed, if any. For 98 | example, if a third party patent license is required to allow Recipient 99 | to distribute the Program, it is Recipient's responsibility to acquire 100 | that license before distributing the Program.

101 | 102 |

d) Each Contributor represents that to its knowledge it 103 | has sufficient copyright rights in its Contribution, if any, to grant 104 | the copyright license set forth in this Agreement.

105 | 106 |

3. REQUIREMENTS

107 | 108 |

A Contributor may choose to distribute the Program in object code 109 | form under its own license agreement, provided that:

110 | 111 |

a) it complies with the terms and conditions of this 112 | Agreement; and

113 | 114 |

b) its license agreement:

115 | 116 |

i) effectively disclaims on behalf of all Contributors 117 | all warranties and conditions, express and implied, including warranties 118 | or conditions of title and non-infringement, and implied warranties or 119 | conditions of merchantability and fitness for a particular purpose;

120 | 121 |

ii) effectively excludes on behalf of all Contributors 122 | all liability for damages, including direct, indirect, special, 123 | incidental and consequential damages, such as lost profits;

124 | 125 |

iii) states that any provisions which differ from this 126 | Agreement are offered by that Contributor alone and not by any other 127 | party; and

128 | 129 |

iv) states that source code for the Program is available 130 | from such Contributor, and informs licensees how to obtain it in a 131 | reasonable manner on or through a medium customarily used for software 132 | exchange.

133 | 134 |

When the Program is made available in source code form:

135 | 136 |

a) it must be made available under this Agreement; and

137 | 138 |

b) a copy of this Agreement must be included with each 139 | copy of the Program.

140 | 141 |

Contributors may not remove or alter any copyright notices contained 142 | within the Program.

143 | 144 |

Each Contributor must identify itself as the originator of its 145 | Contribution, if any, in a manner that reasonably allows subsequent 146 | Recipients to identify the originator of the Contribution.

147 | 148 |

4. COMMERCIAL DISTRIBUTION

149 | 150 |

Commercial distributors of software may accept certain 151 | responsibilities with respect to end users, business partners and the 152 | like. While this license is intended to facilitate the commercial use of 153 | the Program, the Contributor who includes the Program in a commercial 154 | product offering should do so in a manner which does not create 155 | potential liability for other Contributors. Therefore, if a Contributor 156 | includes the Program in a commercial product offering, such Contributor 157 | ("Commercial Contributor") hereby agrees to defend and 158 | indemnify every other Contributor ("Indemnified Contributor") 159 | against any losses, damages and costs (collectively "Losses") 160 | arising from claims, lawsuits and other legal actions brought by a third 161 | party against the Indemnified Contributor to the extent caused by the 162 | acts or omissions of such Commercial Contributor in connection with its 163 | distribution of the Program in a commercial product offering. The 164 | obligations in this section do not apply to any claims or Losses 165 | relating to any actual or alleged intellectual property infringement. In 166 | order to qualify, an Indemnified Contributor must: a) promptly notify 167 | the Commercial Contributor in writing of such claim, and b) allow the 168 | Commercial Contributor to control, and cooperate with the Commercial 169 | Contributor in, the defense and any related settlement negotiations. The 170 | Indemnified Contributor may participate in any such claim at its own 171 | expense.

172 | 173 |

For example, a Contributor might include the Program in a commercial 174 | product offering, Product X. That Contributor is then a Commercial 175 | Contributor. If that Commercial Contributor then makes performance 176 | claims, or offers warranties related to Product X, those performance 177 | claims and warranties are such Commercial Contributor's responsibility 178 | alone. Under this section, the Commercial Contributor would have to 179 | defend claims against the other Contributors related to those 180 | performance claims and warranties, and if a court requires any other 181 | Contributor to pay any damages as a result, the Commercial Contributor 182 | must pay those damages.

183 | 184 |

5. NO WARRANTY

185 | 186 |

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS 187 | PROVIDED ON AN "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS 188 | OF ANY KIND, EITHER EXPRESS OR IMPLIED INCLUDING, WITHOUT LIMITATION, 189 | ANY WARRANTIES OR CONDITIONS OF TITLE, NON-INFRINGEMENT, MERCHANTABILITY 190 | OR FITNESS FOR A PARTICULAR PURPOSE. Each Recipient is solely 191 | responsible for determining the appropriateness of using and 192 | distributing the Program and assumes all risks associated with its 193 | exercise of rights under this Agreement , including but not limited to 194 | the risks and costs of program errors, compliance with applicable laws, 195 | damage to or loss of data, programs or equipment, and unavailability or 196 | interruption of operations.

197 | 198 |

6. DISCLAIMER OF LIABILITY

199 | 200 |

EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT 201 | NOR ANY CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, 202 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING 203 | WITHOUT LIMITATION LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF 204 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 205 | NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OR 206 | DISTRIBUTION OF THE PROGRAM OR THE EXERCISE OF ANY RIGHTS GRANTED 207 | HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.

208 | 209 |

7. GENERAL

210 | 211 |

If any provision of this Agreement is invalid or unenforceable under 212 | applicable law, it shall not affect the validity or enforceability of 213 | the remainder of the terms of this Agreement, and without further action 214 | by the parties hereto, such provision shall be reformed to the minimum 215 | extent necessary to make such provision valid and enforceable.

216 | 217 |

If Recipient institutes patent litigation against any entity 218 | (including a cross-claim or counterclaim in a lawsuit) alleging that the 219 | Program itself (excluding combinations of the Program with other 220 | software or hardware) infringes such Recipient's patent(s), then such 221 | Recipient's rights granted under Section 2(b) shall terminate as of the 222 | date such litigation is filed.

223 | 224 |

All Recipient's rights under this Agreement shall terminate if it 225 | fails to comply with any of the material terms or conditions of this 226 | Agreement and does not cure such failure in a reasonable period of time 227 | after becoming aware of such noncompliance. If all Recipient's rights 228 | under this Agreement terminate, Recipient agrees to cease use and 229 | distribution of the Program as soon as reasonably practicable. However, 230 | Recipient's obligations under this Agreement and any licenses granted by 231 | Recipient relating to the Program shall continue and survive.

232 | 233 |

Everyone is permitted to copy and distribute copies of this 234 | Agreement, but in order to avoid inconsistency the Agreement is 235 | copyrighted and may only be modified in the following manner. The 236 | Agreement Steward reserves the right to publish new versions (including 237 | revisions) of this Agreement from time to time. No one other than the 238 | Agreement Steward has the right to modify this Agreement. The Eclipse 239 | Foundation is the initial Agreement Steward. The Eclipse Foundation may 240 | assign the responsibility to serve as the Agreement Steward to a 241 | suitable separate entity. Each new version of the Agreement will be 242 | given a distinguishing version number. The Program (including 243 | Contributions) may always be distributed subject to the version of the 244 | Agreement under which it was received. In addition, after a new version 245 | of the Agreement is published, Contributor may elect to distribute the 246 | Program (including its Contributions) under the new version. Except as 247 | expressly stated in Sections 2(a) and 2(b) above, Recipient receives no 248 | rights or licenses to the intellectual property of any Contributor under 249 | this Agreement, whether expressly, by implication, estoppel or 250 | otherwise. All rights in the Program not expressly granted under this 251 | Agreement are reserved.

252 | 253 |

This Agreement is governed by the laws of the State of New York and 254 | the intellectual property laws of the United States of America. No party 255 | to this Agreement will bring a legal action under this Agreement more 256 | than one year after the cause of action arose. Each party waives its 257 | rights to a jury trial in any resulting litigation.

258 | 259 | 260 | 261 | 262 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/util.cljc: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.util 2 | (:require [clojure.set :as set] 3 | [clojure.string :as str] 4 | [clojure.core.typed.annotator.rep :as r] 5 | #?@(:clj [[clojure.core.typed.coerce-utils :as coerce]]) 6 | )) 7 | 8 | (def ^:dynamic *debug* nil) 9 | (def ^:dynamic *debug-depth* 0) 10 | 11 | (def ^:dynamic *preserve-unknown* nil) 12 | 13 | (def ^:dynamic *used-aliases* nil) 14 | (def ^:dynamic *multispecs-needed* nil) 15 | 16 | (def ^:dynamic *forbidden-aliases* nil) 17 | 18 | #?(:clj 19 | (defn current-time [] (. System (nanoTime)))) 20 | #?(:cljs 21 | (defn current-time [] (.getTime (js/Date.)))) 22 | 23 | (defn kw->sym [k] 24 | {:pre [(keyword? k)] 25 | :post [(symbol? %)]} 26 | (symbol (namespace k) 27 | (name k))) 28 | 29 | ;; https://github.com/r0man/inflections-clj/blob/master/src/inflections/core.cljc 30 | (defn str-name 31 | "Same as `clojure.core/name`, but keeps the namespace for keywords 32 | and symbols." 33 | [x] 34 | (cond 35 | (nil? x) 36 | x 37 | (string? x) 38 | x 39 | (or (keyword? x) 40 | (symbol? x)) 41 | (if-let [ns (namespace x)] 42 | (str ns "/" (name x)) 43 | (name x)))) 44 | (defn coerce 45 | "Coerce the string `s` to the type of `obj`." 46 | [obj s] 47 | (cond 48 | (keyword? obj) 49 | (keyword s) 50 | (symbol? obj) 51 | (symbol s) 52 | :else s)) 53 | (defn camel-case 54 | "Convert `word` to camel case. By default, camel-case converts to 55 | UpperCamelCase. If the argument to camel-case is set to :lower then 56 | camel-case produces lowerCamelCase. The camel-case fn will also 57 | convert \"/\" to \"::\" which is useful for converting paths to 58 | namespaces. 59 | Examples: 60 | (camel-case \"active_record\") 61 | ;=> \"ActiveRecord\" 62 | (camel-case \"active_record\" :lower) 63 | ;=> \"activeRecord\" 64 | (camel-case \"active_record/errors\") 65 | ;=> \"ActiveRecord::Errors\" 66 | (camel-case \"active_record/errors\" :lower) 67 | ;=> \"activeRecord::Errors\"" 68 | [word & [mode]] 69 | (when word 70 | (->> (let [word (str-name word)] 71 | (cond 72 | (= mode :lower) (camel-case word str/lower-case) 73 | (= mode :upper) (camel-case word str/upper-case) 74 | (fn? mode) (str (mode (str (first word))) 75 | (apply str (rest (camel-case word nil)))) 76 | :else (-> (str/replace word #"/(.?)" #(str "::" (str/upper-case (nth % 1)))) 77 | (str/replace #"(^|_|-)(.)" 78 | #(str (if (#{\_ \-} (nth % 1)) 79 | (nth % 1)) 80 | (str/upper-case (nth % 2))))))) 81 | (coerce word)))) 82 | 83 | #?(:clj 84 | (defn ^:private try-resolve-nsyms [nsyms] 85 | (reduce (fn [_ s] 86 | (try 87 | (require [s]) 88 | (reduced s) 89 | (catch #?(:clj Throwable :cljs :default) e 90 | nil))) 91 | nil 92 | nsyms))) 93 | (def spec-ns' 94 | #?(:clj (try-resolve-nsyms '[clojure.spec clojure.spec.alpha]) 95 | :cljs 'clojure.spec.alpha)) 96 | (def core-specs-ns' 97 | #?(:clj (try-resolve-nsyms '[clojure.core.specs clojure.core.specs.alpha]) 98 | :cljs 'clojure.core.specs.alpha)) 99 | 100 | (def spec-ns (or spec-ns' 'clojure.spec.alpha)) 101 | (def core-specs-ns (or core-specs-ns' 'clojure.core.specs.alpha)) 102 | 103 | (def ^:dynamic unparse-type nil) 104 | 105 | (def ^:dynamic *ann-for-ns* 106 | (fn [] #?(:clj *ns* 107 | :cljs (throw (ex-info "No annotation namespace bound" {}))))) 108 | 109 | (defn current-ns [] 110 | #?(:clj (ns-name (*ann-for-ns*)) 111 | :cljs (*ann-for-ns*))) 112 | 113 | #?(:clj 114 | (defn namespace-alias-in [ns maybe-aliased-ns] 115 | {:pre [((some-fn nil? #(instance? clojure.lang.Namespace %)) maybe-aliased-ns)] 116 | :post [((some-fn nil? symbol) %)]} 117 | (get (set/map-invert (ns-aliases ns)) maybe-aliased-ns))) 118 | 119 | (def ^:dynamic *verbose-specs* nil) 120 | 121 | #?(:clj 122 | (defn qualify-symbol-in [nsym s] 123 | {:pre [(symbol? nsym) 124 | (symbol? s) 125 | (not (namespace s))] 126 | :post [(symbol? %)]} 127 | (let [ns (find-ns nsym) 128 | talias (namespace-alias-in (the-ns (current-ns)) ns) 129 | already-referred? (let [actual (let [v (ns-resolve (the-ns (current-ns)) s)] 130 | (when (var? v) 131 | (coerce/var->symbol v))) 132 | desired (symbol (name nsym) 133 | (name s))] 134 | ;(prn actual desired) 135 | (= actual desired))] 136 | (symbol (if *verbose-specs* 137 | (str nsym) 138 | (when-not already-referred? 139 | (or (when talias 140 | (str talias)) 141 | (when ns 142 | (str (ns-name ns))) 143 | (name nsym)))) 144 | (str s)))) 145 | :cljs 146 | (defn qualify-symbol-in [nsym s] 147 | {:pre [(symbol? nsym) 148 | (symbol? s) 149 | (not (namespace s))] 150 | :post [(symbol? %)]} 151 | ;TODO 152 | (symbol (get {'clojure.core.typed "t" 153 | 'clojure.spec.alpha "s" 154 | 'clojure.core nil} 155 | nsym 156 | (str nsym)) 157 | (str s)))) 158 | 159 | (defn qualify-spec-symbol [s] 160 | {:pre [(symbol? s)] 161 | :post [(symbol? %)]} 162 | (qualify-symbol-in spec-ns s)) 163 | 164 | (defn qualify-typed-symbol [s] 165 | {:pre [(symbol? s)] 166 | :post [(symbol? %)]} 167 | (qualify-symbol-in 'clojure.core.typed s)) 168 | 169 | (defn qualify-core-symbol [s] 170 | {:pre [(symbol? s)] 171 | :post [(symbol? %)]} 172 | (qualify-symbol-in 'clojure.core s)) 173 | 174 | ; classify : Any -> Kw 175 | (defn classify [v] 176 | {:pre [(some? v)]} 177 | (cond 178 | ;(nil? v) :nil 179 | (char? v) :char 180 | (int? v) :int 181 | (integer? v) :integer 182 | #?@(:clj [(decimal? v) :decimal]) 183 | (number? v) :number 184 | (vector? v) :vector 185 | (map? v) :map 186 | (boolean? v) :boolean 187 | (keyword? v) :keyword 188 | (symbol? v) :symbol 189 | (string? v) :string 190 | (fn? v) :ifn 191 | (coll? v) :coll 192 | (seqable? v) :seqable 193 | #?@(:clj [(instance? clojure.lang.ITransientCollection v) :transient]) 194 | :else #?(:clj (.getName (class v)) 195 | :cljs (goog/typeOf v)))) 196 | 197 | (def list*-force (comp doall list*)) 198 | 199 | (defn update-env [env & args] 200 | (apply update env (current-ns) args)) 201 | 202 | (defn update-type-env-in-ns [env ns & args] 203 | (apply update-in env [(ns-name ns) :type-env] args)) 204 | 205 | (defn update-type-env [env & args] 206 | (apply update-type-env-in-ns env (current-ns) args)) 207 | 208 | (defn update-alias-env [env & args] 209 | (apply update-in env [(current-ns) :alias-env] args)) 210 | 211 | (def ^:dynamic *envs* 212 | (atom {})) 213 | 214 | (defn get-env [env] 215 | {:pre [(map? env)]} 216 | (get env (current-ns))) 217 | 218 | (defn type-env 219 | ;([] (type-env @*envs*)) 220 | ([env] (get (get-env env) :type-env))) 221 | 222 | (defn alias-env 223 | ;([] (alias-env @*envs*)) 224 | ([env] (get (get-env env) :alias-env))) 225 | 226 | (defn resolve-alias [env {:keys [name] :as a}] 227 | {:pre [(map? env) 228 | (r/alias? a) 229 | (symbol? name)] 230 | :post [(r/type? %)]} 231 | ;(prn "resolve-alias" name (keys (alias-env env))) 232 | (get (alias-env env) name)) 233 | 234 | ; Env Type -> (Vec Sym) 235 | (defn fv 236 | "Returns the aliases referred in this type, in order of 237 | discovery. If recur? is true, also find aliases 238 | referred by other aliases found." 239 | ([env v] (fv env v false #{})) 240 | ([env v recur?] (fv env v recur? #{})) 241 | ([env v recur? seen-alias] 242 | {:pre [(map? env) 243 | (r/type? v)] 244 | :post [(vector? %) 245 | ;expensive 246 | #_(every? symbol? %)]} 247 | ;(prn "fv" v) 248 | (let [fv (fn 249 | ([v] (fv env v recur? seen-alias)) 250 | ([v recur? seen-alias] 251 | (fv env v recur? seen-alias))) 252 | fvs (case (:op v) 253 | (:free :Top :unknown :val) [] 254 | :HMap (into [] 255 | (mapcat fv) 256 | (concat 257 | (-> v :clojure.core.typed.annotator.rep/HMap-req vals) 258 | (-> v :clojure.core.typed.annotator.rep/HMap-opt vals))) 259 | :HVec (into [] 260 | (mapcat fv) 261 | (-> v :vec)) 262 | :union (into [] 263 | (mapcat fv) 264 | (-> v :types)) 265 | (:unresolved-class :class) 266 | (into [] 267 | (mapcat fv) 268 | (-> v :args)) 269 | :alias (if (seen-alias v) 270 | [] 271 | (conj 272 | (if recur? 273 | (fv (resolve-alias env v) 274 | recur? 275 | (conj seen-alias v)) 276 | []) 277 | (:name v))) 278 | :IFn (into [] 279 | (mapcat (fn [f'] 280 | (into (into [] 281 | (mapcat fv) 282 | (:dom f')) 283 | (fv (:rng f'))))) 284 | (:arities v)))] 285 | fvs))) 286 | 287 | (def ^:dynamic *spec* false) 288 | 289 | (defn unp [t] 290 | (binding [*spec* false] 291 | (unparse-type t))) 292 | 293 | (defn intersection-or-empty [[& args]] 294 | (if args 295 | (apply set/intersection args) 296 | #{})) 297 | 298 | ;; HMap utils 299 | 300 | (defn map-key-set [m] 301 | (set (keys m))) 302 | 303 | (defn HMap-req-keyset [t] 304 | {:pre [(r/HMap? t)] 305 | :post [(set? %) 306 | (every? keyword? %)]} 307 | (let [m (map-key-set (:clojure.core.typed.annotator.rep/HMap-req t))] 308 | ;(when (not (every? keyword? m)) 309 | ; (prn "bad HMap-req-keyset" m)) 310 | m)) 311 | 312 | (defn HMap-common-req-keys [ms] 313 | {:pre [(every? r/HMap? ms)] 314 | :post [(set? %) 315 | (every? keyword? %)]} 316 | (intersection-or-empty 317 | (map HMap-req-keyset ms))) 318 | 319 | (defn nil-val? [t] 320 | (boolean 321 | (and (#{:val} (:op t)) 322 | (nil? (:val t))))) 323 | 324 | (def kw-val? (every-pred r/val? (comp keyword? :val))) 325 | 326 | (defn kw-vals? [t] 327 | (boolean 328 | (or (kw-val? t) 329 | (when (r/union? t) 330 | (every? kw-val? (:types t)))))) 331 | 332 | (defn HMap-likely-tag-key 333 | ([hmaps] (some #(HMap-likely-tag-key hmaps %) 334 | (HMap-common-req-keys hmaps))) 335 | ([hmaps k] 336 | {:pre [(every? r/HMap? hmaps) 337 | (keyword? k)] 338 | :post [((some-fn nil? keyword?) %)]} 339 | (when (every? (fn [m] 340 | {:pre [(r/HMap? m)]} 341 | (kw-vals? (get (:clojure.core.typed.annotator.rep/HMap-req m) k))) 342 | hmaps) 343 | k))) 344 | 345 | ;; resolving aliases 346 | 347 | (defn fully-resolve-alias 348 | ([env a] (fully-resolve-alias env a #{})) 349 | ([env a seen] 350 | (if (r/alias? a) 351 | (do (assert (not (contains? seen (:name a))) "Infinite type detected") 352 | (recur env (resolve-alias env a) 353 | (conj seen (:name a)))) 354 | a))) 355 | 356 | (defn find-top-level-var [top-level-def] 357 | #?(:cljs nil 358 | :clj 359 | (when (and (symbol? top-level-def) 360 | (namespace top-level-def)) ;; testing purposes 361 | (some-> top-level-def find-var)))) 362 | 363 | (def alternative-arglists (atom {})) 364 | 365 | (defn arglists-for-top-level-var [top-level-var] 366 | #?(:cljs nil 367 | :clj 368 | (when top-level-var 369 | (or (-> top-level-var meta :arglists) 370 | (->> top-level-var coerce/var->symbol (get @alternative-arglists)))))) 371 | 372 | (defn separate-fixed-from-rest-arglists [arglists] 373 | (group-by (fn [v] 374 | {:pre [(vector? v)]} 375 | (if (and (<= 2 (count v)) 376 | (#{'&} (get v (- (count v) 2)))) 377 | :rest 378 | :fixed)) 379 | arglists)) 380 | 381 | (defn uniquify [ss] 382 | {:pre [(every? keyword? ss)] 383 | :post [(every? keyword? %)]} 384 | (cond 385 | (or (empty? ss) 386 | (apply distinct? ss)) ss 387 | :else 388 | (let [repeats (into {} 389 | (remove (comp #{1} val)) 390 | (frequencies ss)) 391 | ;; first, let's try and just append an index 392 | ;; to each repeated entry. If that fails, just gensym. 393 | optimistic-attempt (map-indexed 394 | (fn [i s] 395 | {:pre [(keyword? s)] 396 | :post [(keyword? %)]} 397 | (if (contains? repeats s) 398 | (keyword (str (name s) "-" i)) 399 | s)) 400 | ss)] 401 | (if (apply distinct? optimistic-attempt) 402 | optimistic-attempt 403 | (map (fn [s] 404 | {:pre [(keyword? s)] 405 | :post [(keyword? %)]} 406 | (if (contains? repeats s) 407 | (keyword (str (gensym (name s)))) 408 | s)) 409 | ss))))) 410 | 411 | (defn gen-unique-alias-name [env config sym] 412 | (if (or (contains? (alias-env env) sym) 413 | (when-let [forbidden-aliases *forbidden-aliases*] 414 | (contains? @forbidden-aliases sym))) 415 | (gen-unique-alias-name env config (symbol (str (name sym) "__0"))) 416 | sym)) 417 | 418 | #?(:clj 419 | (defn macro-symbol? [s] 420 | {:pre [(symbol? s)]} 421 | (boolean 422 | (when (namespace s) 423 | (when-let [v (find-var s)] 424 | (:macro (meta v))))))) 425 | 426 | (defn imported-symbol? [s] 427 | {:pre [(symbol? s)]} 428 | (not= (str (ns-name (current-ns))) 429 | (namespace s))) 430 | 431 | (defn top-level-self-reference? 432 | ([env t self] (top-level-self-reference? env t self #{})) 433 | ([env t self seen] 434 | {:pre [(symbol? self)]} 435 | (cond 436 | (r/alias? t) (or (= (:name t) self) 437 | (if (seen (:name t)) 438 | false 439 | (top-level-self-reference? 440 | env 441 | (resolve-alias env t) 442 | self 443 | (conj seen (:name t))))) 444 | (r/union? t) (boolean (some #(top-level-self-reference? env % self seen) (:types t))) 445 | :else false))) 446 | 447 | (defn register-alias [env config name t] 448 | {:pre [(map? env) 449 | (symbol? name) 450 | (r/type? t)] 451 | :post [(map? %)]} 452 | ;(prn "register" name) 453 | (assert (not (top-level-self-reference? env t name))) 454 | (update-alias-env env assoc name t)) 455 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/core/typed/annotator/test/mini_occ.clj: -------------------------------------------------------------------------------- 1 | ;; FIXME this file is in module-check because it's used by clojure.core.typed.annotator.test.runtime-infer 2 | (ns clojure.core.typed.annotator.test.mini-occ 3 | #_{:lang :core.typed 4 | :core.typed {:features #{:runtime-infer} 5 | :runtime-infer {:collapse #{:E}}} 6 | } 7 | (:require [clojure.test :refer [deftest is]] 8 | [clojure.core.typed :as t :refer [defalias ann]] 9 | [clojure.pprint :refer [pprint]])) 10 | 11 | ;; Start: Generated by clojure.core.typed - DO NOT EDIT 12 | ;; End: Generated by clojure.core.typed - DO NOT EDIT 13 | ;; e ::= x | (if e e e) | (lambda (x :- t) e) | (e e*) | #f | n? | add1 14 | ;; t ::= [x : t -> t] | (not t) | (or t t) | (and t t) | #f | N | Any 15 | ;; p ::= (is e t) | (not p) | (or p p) | (and p p) | (= e e) 16 | ;; ps ::= p* 17 | 18 | #_ 19 | (defalias E 20 | "Expressions" 21 | (t/U '{:E :var, :name t/Sym} 22 | '{:E :if, :test E, :then E, :else E} 23 | '{:E :lambda, :arg t/Sym, :arg-type T, :body E} 24 | '{:E :app, :fun E, :args (t/Vec E)} 25 | '{:E :false} 26 | '{:E :n?} 27 | '{:E :add1})) 28 | #_ 29 | (defalias T 30 | "Types" 31 | (t/U '{:T ':fun, :params (t/Vec '{:name t/Sym :type T}), :return T} 32 | '{:T ':not, :type T} 33 | '{:T ':union, :types (t/Set T)} 34 | '{:T ':intersection, :types (t/Set T)} 35 | '{:T ':false} 36 | '{:T ':num} 37 | '{:T ':refine, :name t/Sym, :prop P})) 38 | #_ 39 | (defalias P 40 | "Propositions" 41 | (t/U '{:P ':is, :exp E, :type T} 42 | '{:P ':=, :exps (t/Set E)} 43 | '{:P ':or, :ps (t/Set P)} 44 | '{:P ':and, :ps (t/Set P)} 45 | '{:P ':not, :p P})) 46 | 47 | #_ 48 | (defalias Ps 49 | "Proposition environments" 50 | (t/Set P)) 51 | 52 | ;n? : [x :- Any -> (is (n? x) Int)] 53 | ;+ : [x :- Int, y : Int -> Int] 54 | 55 | #_(tc (lambda (x) 56 | (if (n? x) 57 | (add1 x) 58 | x))) 59 | 60 | ; ps p -> List List ass 61 | ;(defn prove [ps p] 62 | ; ) 63 | 64 | (declare parse-exp parse-type) 65 | 66 | ; Any -> P 67 | (defn parse-prop [p] 68 | (assert (and (sequential? p) 69 | (seq? p)) 70 | p) 71 | ;(pprint 'foo) 72 | (case (first p) 73 | is (let [[_ e t] p] 74 | {:P :is 75 | :exp (parse-exp e) 76 | :type (parse-type t)}) 77 | = (let [[_ & es] p] 78 | {:P := 79 | :exps (set (map parse-exp es))}) 80 | or (let [[_ & ps] p] 81 | {:P :or 82 | :ps (set (map parse-prop ps))}) 83 | and (let [[_ & ps] p] 84 | {:P :and 85 | :ps (set (map parse-prop ps))}) 86 | not (let [[_ np] p] 87 | {:P :not 88 | :p (parse-prop np)}))) 89 | 90 | (deftest parse-prop-test 91 | (is (= (parse-prop '(is x Any)) 92 | {:P :is, 93 | :exp {:name 'x, :E :var}, 94 | :type {:T :intersection, :types #{}}})) 95 | (is (= (parse-prop '(= (x y) z)) 96 | '{:P :=, :exps #{{:name z, :E :var} 97 | {:args [{:name y, :E :var}], :fun {:name x, :E :var}, :E :app}}})) 98 | (is (= (parse-prop '(or (= (x y) z) 99 | (is x Any))) 100 | '{:P :or, 101 | :ps #{{:P :=, :exps #{{:name z, :E :var} {:args [{:name y, :E :var}], :fun {:name x, :E :var}, :E :app}}} 102 | {:exp {:name x, :E :var}, :P :is, :type {:T :intersection, :types #{}}}}})) 103 | (is (= (parse-prop '(and (= (x y) z) 104 | (is x Any))) 105 | '{:P :and, 106 | :ps #{{:P :=, :exps #{{:name z, :E :var} {:args [{:name y, :E :var}], :fun {:name x, :E :var}, :E :app}}} 107 | {:exp {:name x, :E :var}, :P :is, :type {:T :intersection, :types #{}}}}} 108 | )) 109 | (is (= (parse-prop '(not (= (x y) z))) 110 | '{:P :not, 111 | :p {:P :=, :exps #{{:name z, :E :var} {:args [{:name y, :E :var}], :fun {:name x, :E :var}, :E :app}}}})) 112 | ) 113 | 114 | (declare unparse-exp unparse-type) 115 | 116 | ; P -> Any 117 | (defn unparse-prop [p] 118 | {:pre [(contains? p :P)]} 119 | (case (:P p) 120 | :is `(~'is ~(unparse-exp (:exp p)) 121 | ~(unparse-type (:type p))) 122 | := `(~'= ~@(map unparse-exp (:exps p))) 123 | :or `(~'or ~@(map unparse-prop (:ps p))) 124 | :and `(~'and ~@(map unparse-prop (:ps p))) 125 | :not `(~'not ~(unparse-prop (:p p))))) 126 | 127 | (defn parse-roundtrip [syn] 128 | (= (parse-prop (unparse-prop (parse-prop syn))) 129 | (parse-prop syn))) 130 | 131 | #_ 132 | (unparse-prop 133 | {:P :not, 134 | :p {:P :is, 135 | :exp {:E :var, :name x}, 136 | :type {:T :intersection, :types #{}}}}) 137 | 138 | (deftest unparse-prop-test 139 | (is (parse-roundtrip '(is x Any))) 140 | (is (parse-roundtrip '(= z (x y)))) 141 | (is (parse-roundtrip '(or (= (x y) z) (is x Any)))) 142 | (is (parse-roundtrip '(and (= (x y) z) (is x Any)))) 143 | (is (parse-roundtrip '(not (= (x y) z))))) 144 | 145 | ; Any -> T 146 | (defn parse-type [t] 147 | (cond 148 | (vector? t) (let [[args [_ ret]] (split-at (- (count t) 2) t) 149 | args (map (t/ann-form 150 | (fn [[x _ t]] 151 | {:name x 152 | :type (parse-type t)}) 153 | [(t/Coll (t/U t/Sym ':-)) :-> NameTypeMap]) 154 | (partition 3 args))] 155 | (assert (#{'->} (get t (- (count t) 2))) 156 | (get t (- (count t) 2))) 157 | {:T :fun 158 | :params (vec args) 159 | :return (parse-type ret)}) 160 | (seq? t) (case (first t) 161 | not (let [[_ t1] t] 162 | {:T :not 163 | :type (parse-type t)}) 164 | or (let [[_ & ts] t] 165 | {:T :union 166 | :types (set (map parse-type ts))}) 167 | and (let [[_ & ts] t] 168 | {:T :intersection 169 | :types (set (map parse-type ts))}) 170 | refine (let [[_ [x] p] t] 171 | (assert (symbol? x)) 172 | {:T :refine 173 | :name x 174 | :prop (parse-prop t)})) 175 | (false? t) {:T :false} 176 | ('#{Num} t) {:T :num} 177 | ('#{Any} t) {:T :intersection :types #{}} 178 | :else (assert false t))) 179 | 180 | (deftest parse-types-test 181 | (is (parse-type '(and false Num)))) 182 | 183 | (defn unparse-type [t] 184 | {:pre [(contains? t :T)]} 185 | (case (:T t) 186 | :fun `[~@(mapcat (fn [{:keys [name type]}] 187 | [name :- (unparse-type type)]) 188 | (:params t)) 189 | ~'-> 190 | ~(unparse-type (:return t))] 191 | :not `(~'not (unparse-type (:type t))) 192 | :union `(~'or ~@(map unparse-type (:types t))) 193 | :intersection (if (zero? (count (:types t))) 194 | 'Any 195 | `(~'and ~@(map unparse-type (:types t)))) 196 | :false false 197 | :num 'Num 198 | :refine `(~'refine [~(:name t)] 199 | ~(unparse-prop (:prop t))))) 200 | 201 | ; parse-exp : Any -> E 202 | (defn parse-exp [e] 203 | (cond 204 | (symbol? e) {:E :var, :name e} 205 | (false? e) {:E :false} 206 | (= 'n? e) {:E :n?} 207 | (= 'add1 e) {:E :add1} 208 | (seq? e) (case (first e) 209 | if (let [[_ e1 e2 e3] e] 210 | (assert (= 4 (count e))) 211 | {:E :if 212 | :test (parse-exp e1) 213 | :then (parse-exp e2) 214 | :else (parse-exp e3)}) 215 | lambda (let [[_ [x _ t :as param] b] e] 216 | (assert (= 3 (count e))) 217 | (assert (= 3 (count param))) 218 | (assert (symbol? x)) 219 | {:E :lambda 220 | :arg x 221 | :arg-type (parse-type t) 222 | :body (parse-exp b)}) 223 | (let [[f & args] e] 224 | (assert (<= 1 (count e))) 225 | {:E :app 226 | :fun (parse-exp f) 227 | :args (mapv parse-exp args)})) 228 | :else (assert false e))) 229 | 230 | (deftest parse-exp-test 231 | (is (= (parse-exp 'x) 232 | '{:name x, :E :var})) 233 | (is (= (parse-exp '(lambda (x :- Any) x)) 234 | '{:E :lambda, 235 | :arg x, 236 | :body {:name x, :E :var}, 237 | :arg-type {:T :intersection, :types #{}}})) 238 | (is (= (parse-exp '(lambda (x :- (and false Num)) x)) 239 | '{:E :lambda, 240 | :arg x, 241 | :body {:name x, :E :var}, 242 | :arg-type {:T :intersection, 243 | :types #{{:T :false} 244 | {:T :num}}}})) 245 | (is (= (parse-exp '(if x y z)) 246 | '{:E :if, 247 | :test {:name x, :E :var}, 248 | :then {:name y, :E :var}, 249 | :else {:name z, :E :var}})) 250 | (is (= (parse-exp '(x y z)) 251 | '{:E :app, 252 | :fun {:name x, :E :var}, 253 | :args [{:name y, :E :var} {:name z, :E :var}]})) 254 | (is (= (parse-exp '((lambda (x :- Any) x) y)) 255 | '{:args [{:name y, :E :var}], 256 | :fun {:E :lambda, :arg x, :body {:name x, :E :var}, :arg-type {:T :intersection, :types #{}}}, 257 | :E :app})) 258 | (is (= (parse-exp 'false) 259 | {:E :false})) 260 | (is (= (parse-exp 'add1) 261 | '{:name add1, :E :var}))) 262 | 263 | ; E -> Any 264 | (defn unparse-exp [e] 265 | {:pre [(:E e)]} 266 | (case (:E e) 267 | :var (:name e) 268 | :if `(~'if ~(unparse-exp (:test e)) 269 | ~(unparse-exp (:then e)) 270 | ~(unparse-exp (:else e))) 271 | :lambda `(~'lambda (~(:arg e) :- ~(unparse-type (:arg-type e))) 272 | ~(unparse-exp (:body e))) 273 | :app `(~(unparse-exp (:fun e)) 274 | ~@(map unparse-exp (:args e))) 275 | :false false 276 | :n? 'n? 277 | :add1 'add1 278 | (throw (Exception. (str "No matching clause: " (pr-str (:E e))))))) 279 | 280 | ; eval-exp : E -> Any 281 | #_ 282 | (defn eval-exp [e] 283 | (case)) 284 | 285 | ; tc : Ps E -> T 286 | (defn check [ps e] 287 | {:pre [(set? ps) 288 | (every? :P ps) 289 | (:E e)] 290 | :post [(:T %)]} 291 | (case (:E e) 292 | :false {:T :false} 293 | :lambda {:T :fun 294 | :params [{:name (:arg e), :type (:arg-type e)}] 295 | :return (check (conj ps {:P :is, :exp (:arg e), :type (:arg-type e)}) 296 | (:body e))} 297 | :add1 (parse-type '[x :- Num -> Num]) 298 | :n? (parse-type '[x :- Any -> (refine [r] 299 | (or (and (is r true) 300 | (is x Num)) 301 | (and (is r false) 302 | (is x (not Num)))))]) 303 | :app (let [[e1 e2] e 304 | t1 (check ps e1) 305 | t2 (check ps e2)] 306 | (assert (#{:fun} (:T t1)) t1) 307 | ;; TODO check argument 308 | (assert false) 309 | {:T :intersection} 310 | ))) 311 | ; )) 312 | ;:var (prove ps {:P :is, :exp e, :type t}) 313 | 314 | ; Any Any -> Any 315 | (defn tc [ps e] 316 | (-> 317 | (check (into #{} (map parse-prop ps)) 318 | (parse-exp e)) 319 | unparse-type)) 320 | 321 | (deftest tc-test 322 | (is (= false 323 | (tc [] false))) 324 | #_(is (= false 325 | (tc [] '(lambda (x :- Num) (add1 x)))))) 326 | 327 | ;; suprise identity function to mess up inference. 328 | (defn id [x] x) 329 | 330 | (deftest id-test 331 | (is (mapv id [(parse-prop '(is x Any)) 332 | (parse-prop '(= (x y) z)) 333 | (parse-prop '(or (= (x y) z) 334 | (is x Any))) 335 | (parse-prop '(and (= (x y) z) 336 | (is x Any))) 337 | (parse-prop '(not (= (x y) z))) 338 | (parse-exp 'x) 339 | (parse-exp '(lambda (x :- Any) x)) 340 | (parse-exp '(if x y z)) 341 | (parse-exp '(x y z)) 342 | (parse-exp '((lambda (x :- Any) x) y)) 343 | (parse-exp 'false) 344 | (parse-exp 'add1) 345 | (parse-type '[x :- Num -> Num])]))) 346 | 347 | (prn "eval is actually happening") 348 | 349 | 350 | 351 | (comment 352 | (defn mcar [m] 353 | (:car m)) 354 | 355 | (deftest mcar-test 356 | (is (mcar {:car 1 357 | :cdr 2})) 358 | (is (mcar {:car {:car 1 :cdr 2} 359 | :cdr {:car 3 :cdr 4} 360 | })) 361 | ) 362 | 363 | (track f [path]) 364 | 365 | (ann g ['{:y Int} -> '{:x Int :y Int}]) 366 | (defn g [m] 367 | (merge m {:x 1})) 368 | 369 | ; Inference result: 370 | ; ['forty-two] : Long 371 | (def forty-two 42) 372 | 373 | (def forty-two 374 | (track 42 ['forty-two])) 375 | 376 | (fn [x] 377 | (track 378 | (f (track x [path {:dom 0}])) 379 | [path :rng])) 380 | 381 | 382 | ; Int Int -> Point 383 | (def point 384 | (fn [x y] 385 | (track 386 | ((fn [x y] 387 | {:x x 388 | :y y}) 389 | (track x ['point {:dom 0}]) 390 | (track y ['point {:dom 1}])) 391 | ['point :rng]))) 392 | 393 | (deftest point-test 394 | (is (= 1 (:x (point 1 2)))) 395 | (is (= 2 (:y (point 1 2))))) 396 | (track 397 | ((fn [x y] 398 | {:x x 399 | :y y}) 400 | (track 1 ['point {:dom 0}]) 401 | (track 2 ['point {:dom 1}])) 402 | ['point :rng]) 403 | 404 | {:x (track 1 ['point :rng (key :x)]) 405 | :y (track 2 ['point :rng (key :y)])} 406 | 407 | {:x 1 ; ['point :rng (key :x)] : Long 408 | :y 2}; ['point :rng (key :y)] : Long 409 | 410 | ; [A -> B] (List A) -> (List B) 411 | (def my-map map) 412 | 413 | (def my-map (track map ['my-map])) 414 | 415 | (def my-map 416 | (fn [f c] 417 | (track 418 | (map 419 | (track f ['my-map {:dom 0}]) 420 | (track c ['my-map {:dom 1}])) 421 | ['my-map :rng]))) 422 | 423 | (deftest my-map-test 424 | (is (= [2 3 4] (my-map inc [1 2 3])))) 425 | 426 | (my-map inc [1 2 3]) 427 | 428 | (track 429 | (map 430 | (track inc ['my-map {:dom 0}]) 431 | (track [1 2 3] ['my-map {:dom 1}])) 432 | ['my-map :rng]) 433 | 434 | (track 435 | (map 436 | ; ['my-map {:dom 0}] : ? -> ? 437 | (fn [n] 438 | (track 439 | (inc 440 | (track n ['my-map {:dom 0} {:dom 0}])) 441 | ['my-map {:dom 0} :rng])) 442 | (track [1 2 3] ['my-map {:dom 1}])) 443 | ['my-map :rng]) 444 | 445 | (track 446 | (map 447 | ; ['my-map {:dom 0}] : ? -> ? 448 | (fn [n] 449 | (track 450 | (inc 451 | (track n ['my-map {:dom 0} {:dom 0}])) 452 | ['my-map {:dom 0} :rng])) 453 | ; ['my-map {:dom 1} {:index 0}] : Long 454 | ; ['my-map {:dom 1} {:index 1}] : Long 455 | ; ['my-map {:dom 1} {:index 2}] : Long 456 | [1 2 3]) 457 | ['my-map :rng]) 458 | 459 | 460 | ; ['my-map {:dom 0} {:dom 0}] : Long 461 | ; ['my-map {:dom 0} :rng] : Long 462 | ; ['my-map {:dom 0} {:dom 0}] : Long 463 | ; ['my-map {:dom 0} :rng] : Long 464 | ; ['my-map {:dom 0} {:dom 0}] : Long 465 | ; ['my-map {:dom 0} :rng] : Long 466 | (track 467 | [2 3 4] 468 | ['my-map :rng]) 469 | 470 | ; ['my-map :rng {:index 0}] : Long 471 | ; ['my-map :rng {:index 1}] : Long 472 | ; ['my-map :rng {:index 2}] : Long 473 | [2 3 4] 474 | 475 | (def v e) 476 | 477 | (def v (track e ['v])) 478 | 479 | lib 480 | 481 | (track lib ['lib]) 482 | 483 | (track (fn [x] e) [path]) 484 | 485 | (fn [x] 486 | (let [as (atom {}) 487 | x (track x [path {:dom 0}] as)] 488 | (track 489 | ((fn [x] e) x) 490 | [path :rng] 491 | as))) 492 | 493 | (ann point [Long Long -> Point]) 494 | 495 | (defn point [x y] 496 | {:x x 497 | :y y}) 498 | 499 | (def b e) 500 | 501 | (track f [path] nil) 502 | 503 | (track f [path]) 504 | 505 | ;; new hash map per call to 506 | ;; polymorphic function 507 | 508 | (defn track [val path val-path] 509 | ;; merge {(hash val) #{path}} 510 | (swap! val-path update (hash val) conj path) 511 | ...) 512 | 513 | (defn point [1 2] 514 | {:x 1 515 | :y 2}) 516 | 517 | (point 1 2) 518 | 519 | (fn [x] 520 | (let [val-paths (atom {})] 521 | (track 522 | (f (track x [path {:dom 0}] val-paths)) 523 | [path :rng] 524 | val-paths))) 525 | 526 | (def b (track e ['b])) 527 | 528 | str/upper-case 529 | 530 | (track str/upper-case 531 | ['str/upper-case]) 532 | 533 | (ann clojure.string/upper-case [Str -> Str]) 534 | 535 | (atom {x 1 536 | y 2}) 537 | ) 538 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/insert.clj: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.insert 10 | "Utilities to insert (spec or core.typed) annotations into an 11 | existing file on the JVM. 12 | 13 | 14 | " 15 | (:require [clojure.string :as str] 16 | [clojure.java.io :as io] 17 | [clojure.core.typed.coerce-utils :as coerce] 18 | [clojure.tools.reader.reader-types :as rdrt] 19 | [clojure.tools.namespace.parse :as nprs] 20 | [clojure.core.typed.annotator.pprint :refer [pprint pprint-str-no-line]] 21 | [clojure.core.typed.annotator.util :refer [unparse-type 22 | qualify-typed-symbol 23 | qualify-core-symbol 24 | *ann-for-ns*]] 25 | [clojure.pprint :as pp] 26 | [clojure.core.typed.current-impl :as impl] 27 | )) 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;; Inserting/deleting annotations 31 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 32 | 33 | ;; adapted from tools.namespace 34 | (defn update-file 35 | "Reads file as a string, calls f on the string plus any args, then 36 | writes out return value of f as the new contents of file, or writes 37 | content to `out`." 38 | [file ^String out f & args] 39 | {:pre [(instance? java.net.URL file) 40 | ((some-fn nil? string?) out)]} 41 | (let [old (slurp file) 42 | new (str (apply f old args)) 43 | _ (when out 44 | (let [leading-slash? (boolean (#{\/} (first out))) 45 | dirs (apply str (interpose "/" (pop (str/split out #"/")))) 46 | dirs (if leading-slash? 47 | (str "/" dirs) 48 | dirs) 49 | ;_ (prn "creating" dirs) 50 | _ (doto (java.io.File. ^String dirs) 51 | .mkdirs)] 52 | out)) 53 | out (or out file)] 54 | (spit out new) 55 | (println "Output annotations to " out))) 56 | 57 | (defn ns-file-name [sym] 58 | (io/resource 59 | (coerce/ns->file sym))) 60 | 61 | (def generate-ann-start ";; Start: Generated by clojure.core.typed - DO NOT EDIT") 62 | (def generate-ann-end ";; End: Generated by clojure.core.typed - DO NOT EDIT") 63 | 64 | (defn delete-generated-annotations-in-str 65 | "Delete lines between generate-ann-start and generate-ann-end." 66 | [old] 67 | {:pre [(string? old)] 68 | :post [(string? %)]} 69 | (with-open [rdr (java.io.BufferedReader. 70 | (java.io.StringReader. old))] 71 | (loop [current-open false 72 | lines (line-seq rdr) 73 | out []] 74 | (if (seq lines) 75 | (if current-open 76 | (if (= (first lines) 77 | generate-ann-end) 78 | (recur false 79 | (next lines) 80 | out) 81 | (recur current-open 82 | (next lines) 83 | out)) 84 | (if (= (first lines) 85 | generate-ann-start) 86 | (recur true 87 | (next lines) 88 | out) 89 | (recur current-open 90 | (next lines) 91 | (conj out (first lines))))) 92 | (str/join "\n" out))))) 93 | 94 | (defn ns-end-line 95 | "Returns the last line of the ns form." 96 | [s] 97 | {:pre [(string? s)] 98 | :post [(integer? %)]} 99 | (let [ns-form (with-open [pbr (rdrt/indexing-push-back-reader 100 | (rdrt/string-push-back-reader s))] 101 | (nprs/read-ns-decl pbr nprs/clj-read-opts)) 102 | _ (assert ns-form "No namespace form found") 103 | end-line (-> ns-form meta :end-line) 104 | _ (assert (integer? end-line) 105 | (str "No end-line found for ns form" 106 | (meta ns-form)))] 107 | end-line)) 108 | 109 | (def ^:dynamic *indentation* 2) 110 | 111 | (defn split-at-column 112 | ([s column] (split-at-column s column nil)) 113 | ([s column end-column] 114 | (let [before (subs s 0 (dec column)) 115 | after (if end-column 116 | (subs s (dec column) (dec end-column)) 117 | (subs s (dec column)))] 118 | [before after]))) 119 | 120 | ;; returns a pair [leading-first-line file-slice trailing-final-line] 121 | (defn extract-file-slice [ls line column end-line end-column] 122 | (let [;_ (prn "ls" (count ls) (dec line) end-line) 123 | v (subvec ls (dec line) end-line) 124 | first-line (nth v 0) 125 | last-line (peek v) 126 | ;_ (prn "last-line" last-line (dec end-column)) 127 | [before-column after-column] (split-at-column first-line column 128 | (when (= line end-line) 129 | end-column)) 130 | [before-end-column after-end-column] (split-at-column last-line end-column) 131 | ] 132 | [before-column 133 | (if (= 1 (count v)) 134 | (assoc v 135 | 0 after-column) 136 | (assoc v 137 | 0 after-column 138 | (dec (count v)) before-end-column)) 139 | after-end-column])) 140 | 141 | (defn restitch-ls [ls line end-line split] 142 | (vec (concat 143 | (subvec ls 0 (dec line)) 144 | split 145 | (subvec ls end-line)))) 146 | 147 | (defn insert-loop-var [{:keys [line column end-line end-column] :as f} ls] 148 | {:pre [(#{:loop-var} (:clojure.core.typed.annotator.track/track-kind f)) 149 | #_(= line end-line) 150 | #_(< column end-column) 151 | ]} 152 | (let [end-line line 153 | end-column column 154 | [leading file-slice trailing] (extract-file-slice ls line column end-line end-column) 155 | ;_ (prn "leading" leading) 156 | ;_ (prn "file-slice" file-slice) 157 | ;_ (prn "trailing" trailing) 158 | the-ann (binding [*print-length* nil 159 | *print-level* nil] 160 | (with-out-str 161 | ;(print "^") 162 | ;(print (pprint-str-no-line :clojure.core.typed/rt-gen)) 163 | ;(print " ") 164 | (print "^{") 165 | (print (pprint-str-no-line :clojure.core.typed/ann)) 166 | (print " ") 167 | (print (pprint-str-no-line (unparse-type (:type f)))) 168 | (print "} "))) 169 | [full-first-line 170 | offset-first-line] 171 | (if (> (count leading) 0) 172 | (let [extra-columns (atom 0) 173 | last-char (nth leading (dec (count leading)))] 174 | [(str leading 175 | (when-not (#{\[ \space} last-char) 176 | (swap! extra-columns inc) 177 | " ") 178 | the-ann) 179 | (+ @extra-columns (count the-ann))]) 180 | [the-ann (count the-ann)]) 181 | ; FIXME this should always be [""], but it adds a useless new line 182 | ;file-slice 183 | _ (assert (every? #{""} file-slice) 184 | file-slice) 185 | final-split [(str full-first-line trailing)] 186 | new-ls (restitch-ls ls line end-line final-split) 187 | update-line (fn [old-line] 188 | ;; we never add a new line 189 | old-line) 190 | update-column (fn [old-column old-line] 191 | (cond 192 | ;; changes in the current line. Compensate 193 | ;; for the type annotation. 194 | (and (= old-line line) 195 | (< column old-column)) 196 | (+ old-column offset-first-line) 197 | ;; we preserve columns since we don't add 198 | ;; extra indentation. 199 | :else old-column))] 200 | {:ls new-ls 201 | :update-line update-line 202 | :update-column update-column})) 203 | 204 | 205 | (defn insert-local-fn* [{:keys [line column end-line end-column] :as f} ls] 206 | {:pre [(#{:local-fn} (:clojure.core.typed.annotator.track/track-kind f))]} 207 | (let [;_ (prn "current fn" f) 208 | [before-first-pos file-slice trailing] (extract-file-slice ls line column end-line end-column) 209 | ;_ (prn "before-first-pos" before-first-pos) 210 | ;_ (prn "file-slice" file-slice) 211 | ;_ (prn "trailing" trailing) 212 | after-first-pos (nth file-slice 0) 213 | ;_ (prn "after-first-pos" after-first-pos) 214 | before-line (str 215 | before-first-pos 216 | (binding [*print-length* nil 217 | *print-level* nil] 218 | (with-out-str 219 | ;; DON'T DELETE THESE PRINTS 220 | (print "(") 221 | ;(print (str "^" (pprint-str-no-line :clojure.core.typed/auto-gen) " ")) 222 | (print (pprint-str-no-line (qualify-typed-symbol 'ann-form)))))) 223 | indentation *indentation* 224 | indentation-spaces (apply str (repeat (+ (dec column) indentation) " ")) 225 | ;; insert column+indentation spaces 226 | the-fn-line (str indentation-spaces after-first-pos) 227 | 228 | rest-slice (if (= 1 (count file-slice)) 229 | [] 230 | (subvec file-slice 1 (count file-slice))) 231 | 232 | ;; indent each line at column 233 | indented-fn (map (fn [a] 234 | {:pre [(string? a)]} 235 | ;; insert indentation at column if there's already whitespace there 236 | (if (= \space (nth a (dec column))) 237 | (let [;_ (prn "indenting" a) 238 | ;_ (prn "left half " (subs a 0 (dec column))) 239 | ;_ (prn "right half" (subs a (dec column))) 240 | ] 241 | (str (subs a 0 column) 242 | (apply str (repeat indentation " ")) 243 | (subs a column))) 244 | (do 245 | (prn (str 246 | "WARNING: Not indenting line " line 247 | " of " (:ns f) ", found non-whitespace " 248 | " at column " column ".")) 249 | a))) 250 | rest-slice) 251 | ;_ (prn "the type pp" (pprint-str-no-line (unparse-type (:type f)))) 252 | the-type-line (str indentation-spaces 253 | (pprint-str-no-line (unparse-type (:type f))) 254 | ")") 255 | ;; now add any trailing code after end-column 256 | ;; eg. (map (fn ...) c) ==> (map (ann-form (fn ...) ...) 257 | ;; c) 258 | trailing-line (when (not= 0 (count trailing)) 259 | (str (apply str (repeat (dec column) " ")) 260 | ;; TODO compensate for this change in update-column 261 | (if nil #_(= \space (nth trailing 0)) 262 | (subs trailing 1) 263 | trailing))) 264 | 265 | final-split (concat 266 | [before-line 267 | the-fn-line] 268 | indented-fn 269 | [the-type-line] 270 | (when trailing-line 271 | [trailing-line])) 272 | new-ls (restitch-ls ls line end-line final-split) 273 | update-line (fn [old-line] 274 | (cond 275 | ;; occurs before the current changes 276 | (< old-line line) old-line 277 | ;; occurs inside the bounds of the current function. 278 | ;; Since we've added an extra line before this function (the beginning ann-form) 279 | ;; we increment the line. 280 | (<= line old-line end-line) (inc old-line) 281 | ;; occurs after the current function. 282 | ;; We've added possibly 2-3 lines: 283 | ;; - the beginning of the ann-form 284 | ;; - the end of the ann-form 285 | ;; - possibly, the trailing code 286 | :else (if trailing-line 287 | (+ 3 old-line) 288 | (+ 2 old-line)))) 289 | update-column (fn [old-column old-line] 290 | (cond 291 | ;; occurs before the current changes 292 | (< old-line line) old-column 293 | ;; occurs inside the bounds of the current function. 294 | ;; We indent each of these lines by 2. 295 | ;; WARNING: we might not have indented here 296 | (<= line old-line end-line) (+ 2 old-column) 297 | :else old-column))] 298 | {:ls new-ls 299 | :update-line update-line 300 | :update-column update-column})) 301 | 302 | (defn insert-local-fns [local-fns old config] 303 | {:post [(string? %)]} 304 | ;(prn "insert-local-fns" local-fns) 305 | (let [update-coords 306 | (fn [update-line update-column] 307 | ;; adjust the coordinates of any functions that have moved. 308 | (fn [v] 309 | (-> v 310 | (update :line update-line) 311 | (update :end-line update-line) 312 | ;; pass original line 313 | (update :column update-column (:line v)) 314 | ;; pass original end-line 315 | (update :end-column update-column (:end-line v))))) 316 | ;; reverse 317 | sorted-fns (sort-by (juxt :line :column) local-fns) 318 | ls (with-open [pbr (java.io.BufferedReader. 319 | (java.io.StringReader. old))] 320 | (vec (doall (line-seq pbr))))] 321 | ;(prn "top ls" (count ls)) 322 | (loop [ls ls 323 | fns sorted-fns] 324 | ;(prn "current ls") 325 | ;(println (str/join "\n" ls)) 326 | (if (empty? fns) 327 | (str/join "\n" ls) 328 | (let [;; assume these coordinates are correct 329 | f (first fns) 330 | ;_ (prn "current f" f) 331 | {:keys [ls update-line update-column]} 332 | (case (:clojure.core.typed.annotator.track/track-kind f) 333 | :local-fn (insert-local-fn* f ls) 334 | :loop-var (insert-loop-var f ls)) 335 | _ (assert (vector? ls)) 336 | _ (assert (fn? update-line)) 337 | _ (assert (fn? update-column)) 338 | next-fns (map 339 | ;; adjust the coordinates of any functions that have moved. 340 | (update-coords update-line update-column) 341 | (next fns))] 342 | (recur ls 343 | next-fns)))))) 344 | 345 | (comment 346 | (println 347 | (insert-local-fns 348 | [{:clojure.core.typed.annotator.track/track-kind :local-fn 349 | :line 1 :column 1 350 | :end-line 1 :end-column 11 351 | :type {:op :Top}}] 352 | "(fn [a] a)" 353 | {})) 354 | (println 355 | (insert-local-fns 356 | [{:clojure.core.typed.annotator.track/track-kind :local-fn 357 | :line 1 :column 1 358 | :end-line 2 :end-column 5 359 | :type {:op :Top}}] 360 | "(fn [a]\n a) foo" 361 | {})) 362 | (println 363 | (insert-local-fns 364 | [{:clojure.core.typed.annotator.track/track-kind :local-fn 365 | :line 1 :column 3 366 | :end-line 2 :end-column 7 367 | :type {:op :Top}}] 368 | " (fn [a]\n a) foo" 369 | {})) 370 | (println 371 | (insert-local-fns 372 | [{:clojure.core.typed.annotator.track/track-kind :local-fn 373 | :line 1 :column 1 374 | :end-line 1 :end-column 20 375 | :type {:op :Top}} 376 | {:clojure.core.typed.annotator.track/track-kind :local-fn 377 | :line 1 :column 9 378 | :end-line 1 :end-column 19 379 | :type {:op :Top}}] 380 | "(fn [b] (fn [a] a))" 381 | {})) 382 | ) 383 | 384 | (declare prepare-ann) 385 | 386 | (defn insert-generated-annotations-in-str 387 | "Insert annotations after ns form." 388 | [old ns {:keys [replace-top-level? no-local-ann? infer-anns] :as config}] 389 | {:pre [(string? old)] 390 | :post [(string? %)]} 391 | ;(prn "insert" ann-str) 392 | (binding [*ns* (the-ns ns) 393 | *ann-for-ns* #(the-ns ns)] 394 | (let [{:keys [requires top-level local-fns] :as as} (infer-anns ns config) 395 | ann-str (prepare-ann requires top-level config) 396 | _ (assert (string? ann-str)) 397 | old (if no-local-ann? 398 | old 399 | (insert-local-fns local-fns old config)) 400 | old (delete-generated-annotations-in-str old) 401 | insert-after (ns-end-line old)] 402 | (with-open [pbr (java.io.BufferedReader. 403 | (java.io.StringReader. old))] 404 | (loop [ls (line-seq pbr) 405 | current-line 0 406 | out []] 407 | (if (= current-line insert-after) 408 | (str/join "\n" (concat out 409 | [(first ls) 410 | ;"" 411 | ann-str] 412 | (rest ls))) 413 | (if (seq ls) 414 | (recur (next ls) 415 | (inc current-line) 416 | (conj out (first ls))) 417 | (str/join "\n" (concat out 418 | ["" 419 | ann-str]))))))))) 420 | 421 | 422 | 423 | (defn delete-generated-annotations [ns config] 424 | (impl/with-clojure-impl 425 | (update-file (ns-file-name (if (symbol? ns) 426 | ns ;; avoid `the-ns` call in case ns does not exist yet. 427 | (ns-name ns))) 428 | nil 429 | delete-generated-annotations-in-str))) 430 | 431 | (defn prepare-ann [requires top-level config] 432 | {:post [(string? %)]} 433 | (binding [*print-length* nil 434 | *print-level* nil] 435 | (with-out-str 436 | ;; print requires outside start/end annotations so we don't 437 | ;; delete them between runs 438 | (when (seq requires) 439 | (println ";; Automatically added requires by core.typed") 440 | (doseq [[n a] requires] 441 | (pprint (list (qualify-core-symbol 'require) `'[~n :as ~a])))) 442 | (println generate-ann-start) 443 | (doseq [a top-level] 444 | (pprint a)) 445 | (print generate-ann-end)))) 446 | 447 | (defn default-out-dir [{:keys [spec?] :as config}] 448 | (let [cp-root (-> "" java.io.File. .getAbsoluteFile .getPath) 449 | dir-name (str "generated-" (if spec? "spec" "type") "-annotations")] 450 | (str cp-root "/" dir-name))) 451 | 452 | (defn insert-or-replace-generated-annotations [ns {:keys [out-dir] :as config}] 453 | (impl/with-clojure-impl 454 | (let [nsym (ns-name ns) 455 | ^java.net.URL 456 | file-in (ns-file-name nsym)] 457 | (update-file file-in 458 | (when (or out-dir 459 | (not= "file" (.getProtocol file-in))) 460 | (str (or out-dir 461 | (default-out-dir config)) 462 | "/" 463 | (coerce/ns->file nsym))) 464 | insert-generated-annotations-in-str 465 | ns 466 | config)))) 467 | 468 | (defn insert-generated-annotations [ns config] 469 | (insert-or-replace-generated-annotations ns config)) 470 | (defn replace-generated-annotations [ns config] 471 | (insert-or-replace-generated-annotations ns (assoc config :replace-top-level? true))) 472 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/join.cljc: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.join 10 | (:require [clojure.core.typed.annotator.rep :as r 11 | :refer [HMap? unknown? -class? 12 | -class nothing? -val HVec? 13 | type? val? Any? -any 14 | union?]] 15 | [clojure.set :as set] 16 | [clojure.core.typed.annotator.pprint 17 | :refer [unp-str]] 18 | [clojure.core.typed.annotator.debug-macros 19 | :refer [debug-flat time-if-slow]] 20 | [clojure.core.typed.annotator.util 21 | :refer [HMap-common-req-keys 22 | HMap-likely-tag-key 23 | HMap-req-keyset 24 | map-key-set 25 | *preserve-unknown* 26 | unparse-type]] 27 | )) 28 | 29 | ; default-should-join-HMaps? : HMap HMap -> Bool 30 | (defn default-should-join-HMaps? [t1 t2] 31 | {:pre [(HMap? t1) 32 | (HMap? t2)]} 33 | ;; join if the required keys are the same, 34 | ;; and there is not common key mapped to keywords. 35 | ;; TODO and if 75% of the keys are the same 36 | ;; TODO and if common keys are not always different keywords 37 | (let [ts [t1 t2] 38 | t1-map (:clojure.core.typed.annotator.rep/HMap-req t1) 39 | t2-map (:clojure.core.typed.annotator.rep/HMap-req t2) 40 | res 41 | (and 42 | (<= 2 43 | (count 44 | (set/intersection 45 | (map-key-set t1-map) 46 | (map-key-set t2-map)))) 47 | (not 48 | (some 49 | #(HMap-likely-tag-key ts %) 50 | (HMap-common-req-keys ts))) 51 | ;; TODO 52 | #_ 53 | (every? 54 | ;; should return true if we should merge 55 | ;; this entry 56 | (fn [[k left]] 57 | (let [right (t2-map k)] 58 | (or (= left right) 59 | (not ((every-pred (comp #{:val} :op) 60 | (comp keyword? :val)) 61 | left 62 | right))))) 63 | t1-map)) 64 | ] 65 | res 66 | )) 67 | 68 | (declare HMap-join-strategies) 69 | 70 | (def current-HMap-join-strategy :default) 71 | 72 | ; should-join-HMaps? : HMap HMap -> Bool 73 | (defn should-join-HMaps? [t1 t2] 74 | ((get-in HMap-join-strategies [current-HMap-join-strategy :should-join-HMaps?]) 75 | t1 t2)) 76 | 77 | (declare join* join) 78 | 79 | (defn upcast-HVec [h] 80 | {:pre [(#{:HVec} (:op h))] 81 | :post [(type? %)]} 82 | (-class :vector 83 | [(apply join* (:vec h))])) 84 | 85 | (defn default-join-HMaps [t1 t2] 86 | {:pre [(HMap? t1) 87 | (HMap? t2) 88 | ;(should-join-HMaps? t1 t2) 89 | ] 90 | :post [(HMap? %)]} 91 | ;(prn "joining HMaps" 92 | ; (unparse-type t1) 93 | ; (unparse-type t2)) 94 | (let [t1-req (:clojure.core.typed.annotator.rep/HMap-req t1) 95 | t2-req (:clojure.core.typed.annotator.rep/HMap-req t2) 96 | t1-opt (:clojure.core.typed.annotator.rep/HMap-opt t1) 97 | t2-opt (:clojure.core.typed.annotator.rep/HMap-opt t2) 98 | all-reqs (set/union 99 | (map-key-set t1-req) 100 | (map-key-set t2-req)) 101 | common-reqs (set/intersection 102 | (map-key-set t1-req) 103 | (map-key-set t2-req)) 104 | ;; optional keys 105 | new-opts (set/union 106 | (map-key-set t1-opt) 107 | (map-key-set t2-opt) 108 | (set/difference 109 | all-reqs 110 | common-reqs)) 111 | ;; required if not optional in either 112 | new-reqs (set/difference 113 | common-reqs 114 | new-opts) 115 | res ;(debug 116 | ; (println "Joining HMaps:") 117 | {:op :HMap 118 | :clojure.core.typed.annotator.rep/HMap-req (into {} 119 | (map (fn [k] 120 | {:pre [(keyword? k)]} 121 | (let [ts (keep k [t1-req t2-req])] 122 | ;(prn "req k" k) 123 | ;(prn "ts" ts) 124 | (assert (seq ts)) 125 | [k (apply join* ts)]))) 126 | new-reqs) 127 | :clojure.core.typed.annotator.rep/HMap-opt (into {} 128 | (map (fn [k] 129 | {:pre [(keyword? k)]} 130 | (let [ts (keep k [t1-req t2-req 131 | t1-opt t2-opt])] 132 | (assert (seq ts)) 133 | [k (apply join* ts)]))) 134 | new-opts)} 135 | ;) 136 | ] 137 | (debug-flat 138 | (println "joint HMaps:" 139 | (unp-str res))) 140 | res 141 | )) 142 | 143 | (def HMap-join-strategies 144 | {:default {:should-join-HMaps? #'default-should-join-HMaps? 145 | :join-HMaps #'default-join-HMaps}}) 146 | 147 | (defn join-HMaps [t1 t2] 148 | ((get-in HMap-join-strategies [current-HMap-join-strategy :join-HMaps]) 149 | t1 t2)) 150 | 151 | (defn merge-HMaps [ms] 152 | {:post [(HMap? %)]} 153 | (reduce join-HMaps (first ms) (rest ms))) 154 | 155 | (defn flatten-union [t] 156 | {:pre [(r/type? t)] 157 | :post [(set? %)]} 158 | (if (#{:union} (:op t)) 159 | (into #{} 160 | (mapcat flatten-union) 161 | (:types t)) 162 | #{t})) 163 | 164 | (defn flatten-unions [ts] 165 | {:pre [;; very slow 166 | #_(every? r/type? ts)] 167 | :post [(set? %)]} 168 | (into #{} 169 | (mapcat flatten-union) 170 | ts)) 171 | 172 | (defn make-Union [args] 173 | ;(debug (println "make-Union") 174 | (let [ts (flatten-unions args) 175 | {hmaps true non-hmaps false} (group-by HMap? ts) 176 | hmaps (set hmaps) 177 | ;_ (debug-flat (println "hmaps:" (mapv unp-str hmaps))) 178 | common-keys (or (when (seq hmaps) 179 | (HMap-common-req-keys hmaps)) 180 | #{}) 181 | ;_ (when (seq hmaps) 182 | ; (debug-flat (println "common-keys:" 183 | ; (pr-str common-keys)))) 184 | likely-tag 185 | (some #(HMap-likely-tag-key hmaps %) common-keys) 186 | ;_ (prn "likely-tag" likely-tag) 187 | ;_ (when (seq hmaps) 188 | ; (debug-flat (println "likely-tag:" 189 | ; (pr-str likely-tag)))) 190 | hmaps-merged (let [hmap-by-keys (when (and (seq hmaps) 191 | (not likely-tag)) 192 | (group-by HMap-req-keyset hmaps))] 193 | ;(prn "hmap-by-keys" hmap-by-keys) 194 | ;; if we don't have common keys, collapse everything. 195 | (if hmap-by-keys 196 | ;(debug 197 | ; (println "make-Union: No common key, merging by keys") 198 | (into #{} 199 | (map merge-HMaps) 200 | (vals hmap-by-keys) 201 | ) 202 | ;) 203 | hmaps)) 204 | likely-tag-for-union (atom nil) 205 | ;_ (prn "merged" (mapv unp hmaps-merged)) 206 | ;; if we have more than one keyset, then we must 207 | ;; have "tagged" maps with a common keyword entry (eg. :op, :type). 208 | ;; This ensures we don't keep too much information about generic maps. 209 | hmaps-merged (if (> (count hmaps-merged) 1) 210 | (let [_ (assert (every? HMap? hmaps-merged)) 211 | ] 212 | ;(prn "common-keys" common-keys) 213 | (cond 214 | ;; no keys in common, upcast all maps 215 | (empty? common-keys) 216 | (do 217 | ;(debug-flat (println "no common keys, upcasting to (Map Any Any)")) 218 | ;#{(-class :map [-any -any])} 219 | #{{:op :HMap 220 | :clojure.core.typed.annotator.rep/HMap-req {} 221 | :clojure.core.typed.annotator.rep/HMap-opt (apply merge-with join (mapcat (juxt :clojure.core.typed.annotator.rep/HMap-req :clojure.core.typed.annotator.rep/HMap-opt) hmaps-merged))}}) 222 | 223 | ;; if one of the common keys is always mapped to a singleton keyword, 224 | ;; merge by the value of this key 225 | likely-tag 226 | (let [by-tag (group-by (fn [m] 227 | (get (:clojure.core.typed.annotator.rep/HMap-req m) likely-tag)) 228 | hmaps-merged) 229 | new-maps (into #{} 230 | (map merge-HMaps) 231 | (vals by-tag))] 232 | ;(debug-flat 233 | ; (println "combined HMaps:" 234 | ; (mapv unp-str new-maps))) 235 | (reset! likely-tag-for-union likely-tag) 236 | ;(prn "likely-tag" likely-tag) 237 | ;(prn "by-tag" by-tag) 238 | ;(prn "new-maps" new-maps) 239 | new-maps) 240 | 241 | ;; merge common keys as required, rest are optional 242 | ;; FIXME this is too aggressive for maps that have 243 | ;; clashing dispatch keys. 244 | :else 245 | (let [has-unknown? (atom false) 246 | res 247 | #{{:op :HMap 248 | ;; put all the common required keys as required 249 | :clojure.core.typed.annotator.rep/HMap-req (apply merge-with join 250 | (map (fn [m] 251 | {:pre [(HMap? m)]} 252 | (let [es (select-keys (:clojure.core.typed.annotator.rep/HMap-req m) 253 | common-keys)] 254 | (doseq [[_ v] es] 255 | (when (unknown? v) 256 | (reset! has-unknown? true))) 257 | es)) 258 | hmaps-merged)) 259 | ;; all the rest are optional 260 | :clojure.core.typed.annotator.rep/HMap-opt (apply merge-with join 261 | (map (fn [m] 262 | {:pre [(HMap? m)]} 263 | (let [es 264 | (merge-with join 265 | (:clojure.core.typed.annotator.rep/HMap-opt m) 266 | (apply dissoc (:clojure.core.typed.annotator.rep/HMap-req m) 267 | common-keys))] 268 | (doseq [[_ v] es] 269 | (when (unknown? v) 270 | (reset! has-unknown? true))) 271 | es)) 272 | hmaps-merged)) 273 | }}] 274 | (if @has-unknown? 275 | hmaps-merged 276 | res)))) 277 | hmaps-merged) 278 | ;_ (prn "merged" hmaps-merged) 279 | ;_ (prn "hmaps-merged" (map unparse-type hmaps-merged)) 280 | ;; join all common classes by their arguments, regardless of their variance 281 | non-hmaps (let [{classes true non-classes false} (group-by -class? non-hmaps) 282 | ;; important invariant: all these classes take 1 argument. This is used in 283 | ;; the upcasting logic below. 284 | relevant-seqables #{:seq :coll :list :vector} 285 | ;; upcast seqables if appropriate 286 | classes (let [{seqable-classes true 287 | non-seqable-classes false} 288 | (group-by #(contains? relevant-seqables (:clojure.core.typed.annotator.rep/class-instance %)) classes) 289 | seqable-classes 290 | (if (some (comp #{:list :seq :coll} 291 | :clojure.core.typed.annotator.rep/class-instance) 292 | seqable-classes) 293 | ;; upcast all to Coll since we've probably lost too much type information 294 | ;; to bother keeping seqable-classes around. 295 | [(-class :coll 296 | [(apply join* 297 | ;; assume all seqable-classes take a collection 298 | ;; member type parameter 299 | (map (comp first :args) seqable-classes))])] 300 | seqable-classes)] 301 | (concat seqable-classes non-seqable-classes)) 302 | classes (into #{} 303 | (map (fn [cs] 304 | {:pre [(seq cs) 305 | (every? -class? cs) 306 | (apply = (map (comp count :args) cs))]} 307 | (-class (-> cs first :clojure.core.typed.annotator.rep/class-instance) 308 | (apply mapv join* (map :args cs))))) 309 | (vals (group-by :clojure.core.typed.annotator.rep/class-instance classes)))] 310 | (into classes non-classes)) 311 | 312 | ;; delete HMaps if there's already a Map in this union, 313 | ;; unless it's a (Map Nothing Nothing) 314 | hmaps-merged (if (some (fn [m] 315 | (and (-class? m) 316 | (#{:map} (:clojure.core.typed.annotator.rep/class-instance m)) 317 | (not-every? nothing? (:args m)))) 318 | non-hmaps) 319 | #{} 320 | hmaps-merged) 321 | 322 | ts (into hmaps-merged non-hmaps) 323 | 324 | ;; upcast true/false singletons to Boolean if Boolean is present 325 | ts (if (contains? ts (-class :boolean [])) 326 | (disj ts (-val true) (-val false)) 327 | ts) 328 | 329 | _ (assert (set? ts)) 330 | ;; upcast Long and Double combination to t/Num 331 | ts (cond 332 | (or (and (or (contains? ts (-class :int [])) 333 | (contains? ts (-class :integer []))) 334 | (or (contains? ts (-class :double [])) 335 | (contains? ts (-class :decimal [])))) 336 | (contains? ts (-class :number []))) 337 | (-> (disj ts 338 | (-class :int []) 339 | (-class :integer []) 340 | (-class :double []) 341 | (-class :decimal [])) 342 | (conj (-class :number []))) 343 | 344 | :else ts) 345 | 346 | ;; simplify HVec's 347 | ts (let [merge-same-length-HVecs (fn [hvs] 348 | {:pre [(apply = (map (comp count :vec) hvs))] 349 | :post [(HVec? %)]} 350 | {:op :HVec 351 | :vec (apply mapv join* (map :vec hvs))}) 352 | {HVecs true non-HVecs false} (group-by (comp boolean #{:HVec} :op) ts) 353 | by-count (group-by (comp count :vec) HVecs) 354 | ;; erase HVec's if we have two different length HVec's 355 | should-collapse-HVecs? (< 1 (count by-count)) 356 | [HVecs non-HVecs] (if should-collapse-HVecs? 357 | ;; upcast HVecs 358 | [[] (concat non-HVecs (map upcast-HVec HVecs))] 359 | [(mapv merge-same-length-HVecs (vals by-count)) 360 | non-HVecs]) 361 | _ (assert (every? HVec? HVecs)) 362 | ;; if needed, upcast all HVec's 363 | [HVecs non-HVecs] 364 | (let [;; at this point, collection classes are normalized to either IPC or IPV. 365 | {vec-classes true non-vecs false} 366 | (group-by 367 | (every-pred 368 | -class? 369 | (comp boolean #{:vector :coll} :clojure.core.typed.annotator.rep/class-instance)) 370 | non-HVecs) 371 | _ (assert (= (count non-HVecs) (+ (count vec-classes) (count non-vecs)))) 372 | ;; erase HVec's if we have a IPV class 373 | [HVecs vec-classes] 374 | (if (seq vec-classes) 375 | [[] 376 | (cons 377 | (let [class-name (if (every? (comp boolean #{:vector} :clojure.core.typed.annotator.rep/class-instance) vec-classes) 378 | :vector 379 | :coll) 380 | upcasted-HVecs (map upcast-HVec HVecs)] 381 | (-class class-name 382 | [(apply join* 383 | (concat 384 | (map (comp first :args) (concat vec-classes upcasted-HVecs))))])) 385 | vec-classes)] 386 | [HVecs vec-classes])] 387 | [HVecs (concat vec-classes non-vecs)]) 388 | ] 389 | (into (set non-HVecs) HVecs)) 390 | 391 | 392 | ;; simplify multiple keywords to Kw if 393 | ;ts (let [{kws true non-kws false} (group-by kw-val? ts)] 394 | ; (if (>= (count kws) 2) ;; tweak simplification threshold here 395 | ; (conj (set non-kws) (-class :keyword [])) 396 | ; ts)) 397 | seqable-t? (fn [m] 398 | (boolean 399 | (when (-class? m) 400 | ;; while string is "seqable", it mixes fine with named things. 401 | ;; we don't include :string here so (U Str Sym) is preserved 402 | ;; and not upcast to Any. 403 | (#{:vector :map :coll :seqable} (:clojure.core.typed.annotator.rep/class-instance m))))) 404 | atomic-type? (fn [v] 405 | (boolean 406 | (or 407 | (and (val? v) 408 | (some? (:val v))) 409 | (and (-class? v) 410 | (#{:symbol :string :keyword} 411 | (:clojure.core.typed.annotator.rep/class-instance v)))))) 412 | ] 413 | ;(prn "union ts" ts) 414 | (assert (set? ts)) 415 | (assert (every? (complement #{:union}) (map :op ts))) 416 | (cond 417 | (= 1 (count ts)) (first ts) 418 | 419 | ;; simplify to Any 420 | (some Any? ts) -any 421 | 422 | ;; if there's a mix of collections and non-collection values, 423 | ;; return Any 424 | ;; Allow `nil` liberally. 425 | (let [] 426 | (and ;; either a map or seqable with an atom 427 | (or (seq hmaps-merged) 428 | (seq (filter seqable-t? non-hmaps))) 429 | (seq (filter atomic-type? non-hmaps)))) 430 | (do 431 | ;(prn "simplifying mix of collections and singleton values") 432 | ;(prn "hmaps" (seq hmaps-merged)) 433 | ;(prn "seqables" (filter seqable-t? non-hmaps)) 434 | ;(prn "atomics" (filter atomic-type? non-hmaps)) 435 | -any) 436 | 437 | :else 438 | (let [k @likely-tag-for-union] 439 | (merge 440 | {:op :union 441 | :types (mapv (fn [t] 442 | (if (and (HMap? t) 443 | k) 444 | (vary-meta t assoc ::union-likely-tag k) 445 | t)) 446 | ts)} 447 | #_ 448 | (when-let [k @likely-tag-for-union] 449 | {::union-likely-tag k}))))) 450 | ;) 451 | ) 452 | 453 | ;; `as` is a list of :IFn1 nodes with the same arity 454 | (defn join-IFn1 [as] 455 | {:pre [(seq as) 456 | (every? #{[:IFn1 (-> as first :dom count)]} 457 | (map (juxt :op (comp count :dom)) 458 | as))] 459 | :post [(#{:IFn1} (:op %))]} 460 | (merge 461 | {:op :IFn1 462 | :dom (apply mapv 463 | (fn [& [dom & doms]] 464 | {:pre [dom]} 465 | ;(prn "join IFn IFn dom" (map :op (cons dom doms))) 466 | (apply join* dom doms)) 467 | (map :dom as)) 468 | :rng (let [[rng & rngs] (map :rng as)] 469 | (assert rng) 470 | (apply join* rng rngs)) 471 | :rest (let [all-rests (keep :rest as)] 472 | (when (seq all-rests) 473 | (apply join* all-rests)))})) 474 | 475 | ;; How to choose if we have kwargs. 476 | ;; 477 | ;; - after some fixed number of arguments, the # arguments 478 | ;; need to be multiples of 2 479 | ;; - after the fixed arguments, for each pair [k v] 480 | ;; - k must be a keyword 481 | ;; - v can be anything 482 | (defn group-arities [t1 t2] 483 | {:pre [(#{:IFn} (:op t1)) 484 | (#{:IFn} (:op t2))]} 485 | (vals 486 | (group-by (comp count :dom) 487 | (concat (:arities t1) 488 | (:arities t2))))) 489 | 490 | (defn join-IFn [t1 t2] 491 | {:pre [(#{:IFn} (:op t1)) 492 | (#{:IFn} (:op t2))] 493 | :post [(type? %)]} 494 | (let [grouped (group-arities t1 t2) 495 | arities (mapv join-IFn1 grouped)] 496 | {:op :IFn 497 | :arities arities})) 498 | 499 | ; join : Type Type -> Type 500 | (defn join [t1 t2] 501 | {:pre [(type? t1) 502 | (type? t2)] 503 | :post [(type? %)]} 504 | (time-if-slow 505 | (binding [*preserve-unknown* true] 506 | (str "Join was slow on arguments:" 507 | (:op t1) (:op t2) 508 | (unparse-type t1) (unparse-type t2))) 509 | (let [;id (gensym (apply str (map :op [t1 t2]))) 510 | ;_ (prn "join" id (unparse-type t1) (unparse-type t2)) 511 | res (cond 512 | (= t1 t2) t1 513 | 514 | ;; annihilate unknown 515 | (unknown? t1) t2 516 | (unknown? t2) t1 517 | 518 | (or (union? t1) (union? t2)) 519 | (apply join* (flatten-unions [t1 t2])) 520 | 521 | (and (#{:poly} (:op t1)) 522 | (#{:poly} (:op t2))) 523 | {:op :poly 524 | :known-params (into (:known-params t1) 525 | (:known-params t2)) 526 | :params (merge-with (fn [{w1 :weight 527 | v1 :name 528 | t1 :types} 529 | {w2 :weight 530 | v2 :name 531 | t2 :types}] 532 | ;; throw away v2 533 | ;(prn "Merging:" w1 w2) 534 | {:weight (+ w1 w2) 535 | :name v1 536 | :types (into t1 t2)}) 537 | (:params t1) (:params t2)) 538 | :types (join (:type t1) (:type t2))} 539 | 540 | (#{:poly} (:op t1)) 541 | (update t1 :type join t2) 542 | (#{:poly} (:op t2)) 543 | (update t2 :type join t1) 544 | 545 | (and (#{:class} (:op t1)) 546 | (#{:class} (:op t2)) 547 | (= (:clojure.core.typed.annotator.rep/class-instance t1) 548 | (:clojure.core.typed.annotator.rep/class-instance t2)) 549 | (= (count (:args t1)) 550 | (count (:args t2)))) 551 | (-class (:clojure.core.typed.annotator.rep/class-instance t1) (mapv join (:args t1) (:args t2))) 552 | 553 | (and (#{:class} (:op t1)) 554 | (= :ifn 555 | (:clojure.core.typed.annotator.rep/class-instance t1)) 556 | (#{:IFn} (:op t2))) 557 | t2 558 | 559 | (and (#{:class} (:op t2)) 560 | (= :ifn 561 | (:clojure.core.typed.annotator.rep/class-instance t2)) 562 | (#{:IFn} (:op t1))) 563 | t1 564 | 565 | (and (HMap? t1) 566 | (HMap? t2) 567 | (should-join-HMaps? t1 t2)) 568 | (join-HMaps t1 t2) 569 | 570 | (and (#{:IFn} (:op t1)) 571 | (#{:IFn} (:op t2))) 572 | (join-IFn t1 t2) 573 | 574 | (and (#{:HVec} (:op t1)) 575 | (#{:HVec} (:op t2)) 576 | (= (count (:vec t1)) (count (:vec t2)))) 577 | {:op :HVec 578 | :vec (mapv join (:vec t1) (:vec t2))} 579 | 580 | :else 581 | (let [] 582 | ;(prn "join union fall through") 583 | (make-Union [t1 t2])))] 584 | ;(prn "join result" id (unparse-type res)) 585 | res))) 586 | 587 | (defn join* [& args] 588 | #_(when (< 5 (count args)) 589 | (prn "join* large arguments" (count args))) 590 | (letfn [(merge-type [t as] 591 | {:pre [(type? t) 592 | (not (union? t)) 593 | (set? as)] 594 | :post [(set? %)]} 595 | ;(prn "merge-type" (unparse-type t) (mapv unparse-type as)) 596 | (let [ms (into #{} 597 | (comp 598 | (map #(join t %)) 599 | ;(mapcat flatten-union) 600 | ) 601 | (flatten-unions as)) 602 | res (cond 603 | (empty? ms) #{t} 604 | :else ms)] 605 | ;(prn "merge-type result" (map unparse-type res)) 606 | res))] 607 | (make-Union 608 | (reduce (fn [as t] 609 | (merge-type t as)) 610 | #{} 611 | (flatten-unions args))))) 612 | 613 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/track.cljc: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) Ambrose Bonnaire-Sergeant, Rich Hickey & contributors. 2 | ;; The use and distribution terms for this software are covered by the 3 | ;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) 4 | ;; which can be found in the file epl-v10.html at the root of this distribution. 5 | ;; By using this software in any fashion, you are agreeing to be bound by 6 | ;; the terms of this license. 7 | ;; You must not remove this notice, or any other, from this software. 8 | 9 | (ns clojure.core.typed.annotator.track 10 | (:require #?@(:clj [[potemkin.collections :as pot]]) 11 | [clojure.core.typed.annotator.rep :refer [-val key-path map-vals-path 12 | infer-results -class -any 13 | fn-dom-path fn-rng-path 14 | -nothing seq-entry 15 | transient-vector-entry index-path 16 | vec-entry-path 17 | set-entry make-HMap 18 | map-keys-path 19 | atom-contents 20 | var-path]] 21 | [clojure.core.typed.contract-utils :as con] 22 | [clojure.core.typed.annotator.env :refer [add-infer-results! 23 | results-atom]] 24 | [clojure.core.typed.annotator.util :refer [classify]] 25 | [clojure.math.combinatorics :as comb] 26 | [clojure.core.typed.util-vars :as vs] 27 | [clojure.core.typed.current-impl :as impl] 28 | )) 29 | 30 | (defn local-fn-symbol? [s] 31 | (= :local-fn (:clojure.core.typed.annotator.track/track-kind (meta s)))) 32 | 33 | (defn loop-var-symbol? [s] 34 | (= :loop-var (:clojure.core.typed.annotator.track/track-kind (meta s)))) 35 | 36 | (defn extend-paths [paths extension] 37 | (into #{} 38 | (map (fn [path] 39 | (conj path extension))) 40 | paths)) 41 | 42 | (def ^:dynamic *should-track* true) 43 | 44 | (def ^:const apply-realize-limit 20) 45 | 46 | (def ^:dynamic *track-depth* nil #_5) 47 | (def ^:dynamic *track-count* nil #_5) 48 | (def ^:dynamic *root-results* nil #_5) 49 | 50 | (def stored-call-ids (atom {})) 51 | 52 | (defn gen-call-id [paths] 53 | [paths (swap! stored-call-ids update paths (fnil inc 0))]) 54 | 55 | (declare track) 56 | 57 | #?(:clj 58 | (pot/def-map-type PersistentMapProxy [^clojure.lang.IPersistentMap m k-to-track-info config results-atom 59 | ;; if started as HMap tracking map, map from kw->Type 60 | ;; for all keyword keys with keyword values 61 | current-kw-entries-types 62 | current-ks current-all-kws?] 63 | Object 64 | (toString [this] (.toString m)) 65 | (equals [this obj] (.equals m obj)) 66 | 67 | clojure.lang.Counted 68 | (count [this] (count m)) 69 | 70 | ;; TODO (.seq this), .iterator, .vals 71 | java.util.Map 72 | (size [this] (.size ^java.util.Map m)) 73 | (containsKey [this obj] (.containsKey ^java.util.Map m obj)) 74 | 75 | (equiv [this obj] 76 | (.equiv m obj)) 77 | 78 | (get [this key default-value] (if (contains? m key) 79 | (let [v (get m key) 80 | track-infos (get k-to-track-info key)] 81 | (if (empty? track-infos) 82 | ;; this entry has no relation to paths 83 | v 84 | (let [{:keys [paths call-ids]} 85 | (binding [*should-track* false] 86 | (reduce (fn [acc [{:keys [ks kw-entries-types all-kws?] :as track-info} 87 | {:keys [paths call-ids]}]] 88 | {:pre [(boolean? all-kws?) 89 | (set? ks) 90 | (map? kw-entries-types) 91 | (set? paths) 92 | (set? call-ids)]} 93 | (let [path-extension (if (and (keyword? key) 94 | all-kws?) 95 | ;; HMap tracking 96 | (key-path kw-entries-types ks key) 97 | ;; homogeneous map tracking 98 | ;; FIXME what about map-keys-path tracking? 99 | (map-vals-path))] 100 | (-> acc 101 | (update :call-ids into call-ids) 102 | (update :paths into (extend-paths paths path-extension))))) 103 | {:paths #{} 104 | :call-ids #{}} 105 | track-infos))] 106 | (track config results-atom v paths call-ids)))) 107 | default-value)) 108 | (assoc [this key value] (PersistentMapProxy. (assoc m key value) 109 | ;; new value has no relation to paths 110 | (dissoc k-to-track-info key) 111 | config 112 | results-atom 113 | (if (and (keyword? key) 114 | (keyword? value)) 115 | (assoc current-kw-entries-types key (-val value)) 116 | current-kw-entries-types) 117 | (conj current-ks key) 118 | (and current-all-kws? 119 | (keyword? key)))) 120 | (dissoc [this key] (PersistentMapProxy. (dissoc m key) 121 | ;; new value has no relation to paths 122 | (dissoc k-to-track-info key) 123 | config 124 | results-atom 125 | (dissoc current-kw-entries-types key) 126 | (disj current-ks key) 127 | (or current-all-kws? 128 | ;; might have deleted the last non-keyword key 129 | (every? keyword? (disj current-ks key))))) 130 | ;; TODO wrap 131 | (keys [this] (keys m)) 132 | ;; TODO vals 133 | (meta [this] (meta m)) 134 | (hashCode [this] (.hashCode ^Object m)) 135 | (hasheq [this] (.hasheq ^clojure.lang.IHashEq m)) 136 | (with-meta [this meta] (PersistentMapProxy. (with-meta m meta) 137 | k-to-track-info 138 | config 139 | results-atom 140 | current-kw-entries-types 141 | current-ks 142 | current-all-kws?)))) 143 | 144 | (defn unwrap-value [v] 145 | (if-some [[_ u] (or (-> v meta (find ::unwrapped-fn)) 146 | (-> v meta (find ::unwrapped-seq)) 147 | #?(:clj 148 | (when (instance? PersistentMapProxy v) 149 | [nil (.m ^PersistentMapProxy v)])))] 150 | ;; values are only wrapped one level, no recursion calls needed 151 | u 152 | v)) 153 | 154 | (def track-metric-cache (atom {})) 155 | 156 | ; track : (Atom InferResultEnv) Value Path -> Value 157 | (defn track 158 | ([{:keys [track-depth track-count track-strategy track-metric root-results force-depth] :as config} results-atom v paths call-ids] 159 | {:pre [((con/set-c? vector?) paths) 160 | (seq paths) 161 | ((con/set-c? vector?) call-ids)]} 162 | #?(:clj 163 | (when (string? track-metric) 164 | (let [tm (or (get @track-metric-cache track-metric) 165 | (-> track-metric read-string eval)) 166 | _ (when-not (@track-metric-cache track-metric) 167 | (reset! track-metric-cache {track-metric tm}))] 168 | (tm (merge config 169 | {:results-atom results-atom 170 | :v v 171 | :paths paths 172 | :call-ids call-ids}))))) 173 | (let [;FIXME memory intensive 174 | #_#_ 175 | _ (let [hs ((juxt 176 | #(System/identityHashCode %) 177 | class) 178 | (unwrap-value v))] 179 | ;(prn "call-ids" (map (comp #(map (comp :name first) %) first) call-ids)) 180 | (swap! results-atom update :call-flows 181 | (fn [flows] 182 | (reduce (fn [flows call-id] 183 | (reduce (fn [flows path] 184 | (let [vname (-> path first :name) 185 | _ (assert (symbol? vname))] 186 | (update-in flows [vname call-id] 187 | (fn [m] 188 | (-> m 189 | (update-in [:path-hashes path] (fnil conj #{}) hs) 190 | (update-in [:hash-occurrences hs] (fnil conj #{}) path)))))) 191 | flows 192 | paths)) 193 | flows 194 | call-ids)))) 195 | paths-that-exceed-root-results (let [rr (:root-results @results-atom)] 196 | (when root-results 197 | (filter #(< root-results (get rr (-> % first :name) 0)) 198 | paths)))] 199 | (cond 200 | ((some-fn keyword? nil? false?) v) 201 | (do 202 | (add-infer-results! results-atom (infer-results (remove (set paths-that-exceed-root-results) paths) 203 | (-val v))) 204 | v) 205 | 206 | ;; cut off path 207 | (or 208 | (not *should-track*) 209 | ;; cap at 1000 results per var 210 | (seq paths-that-exceed-root-results) 211 | (let [smallest-path-count (apply min (map count paths))] 212 | (if (and force-depth (>= force-depth smallest-path-count)) 213 | false 214 | (when track-depth 215 | (> smallest-path-count track-depth))))) 216 | ;(debug 217 | ; (println "Cut off inference at path " 218 | ; (unparse-path path) 219 | ; "(due to " (if *should-track* 220 | ; (str "track depth of" *track-depth* 221 | ; "being exceeded") 222 | ; (str "disabled tracking of internal ops")) 223 | ; ")") 224 | (let [;; record as unknown so this doesn't 225 | ;; cut off actually recursive types. 226 | _ (add-infer-results! results-atom (infer-results (remove (set paths-that-exceed-root-results) paths) 227 | {:op :unknown}))] 228 | (unwrap-value v)) 229 | ;) 230 | 231 | ;; only accurate up to 20 arguments. 232 | ;; all arities 21 and over will collapse into one. 233 | (fn? v) (let [[paths unwrapped-fn] (if (-> v meta ::wrapped-fn?) 234 | ((juxt ::paths ::unwrapped-fn) 235 | ;; combine paths 236 | (update (meta v) ::paths into paths)) 237 | [paths v]) 238 | _ (assert (set? paths)) 239 | ;; Now, remember this value is at least a function, in case it is never invoked. 240 | ;; This will get noted redundantly for older paths, if that's 241 | ;; some kind of issue, we should remember which paths we've already noted. 242 | _ (add-infer-results! results-atom (infer-results paths (-class :ifn []))) 243 | call-ids (conj call-ids (gen-call-id paths)) 244 | ;; space-efficient function wrapping 245 | wrap-fn (fn [paths unwrapped-fn] 246 | (with-meta 247 | (fn [& args] 248 | (let [blen (bounded-count apply-realize-limit args) ;; apply only realises 20 places 249 | _ (when (= 0 blen) 250 | (track config results-atom 251 | -any ;ignored, just noting this is called with 0-args 252 | (extend-paths paths (fn-dom-path 0 -1)) 253 | call-ids)) 254 | ;; here we throw away arities after 20 places. 255 | ;; no concrete reason for this other than it feeling like a sensible 256 | ;; compromise. 257 | args (map-indexed 258 | (fn [n arg] 259 | (if (< n blen) 260 | (track config results-atom arg 261 | (extend-paths paths (fn-dom-path blen n)) 262 | call-ids) 263 | arg)) 264 | args)] 265 | (track config results-atom (apply unwrapped-fn args) 266 | (extend-paths paths (fn-rng-path blen)) 267 | call-ids))) 268 | (merge (meta unwrapped-fn) 269 | {::wrapped-fn? true 270 | ::paths paths 271 | ::unwrapped-fn unwrapped-fn})))] 272 | (wrap-fn paths v)) 273 | 274 | (list? v) 275 | (let [] 276 | (when (empty? v) 277 | (add-infer-results! 278 | results-atom 279 | (infer-results paths 280 | (-class :list [-nothing])))) 281 | (let [res 282 | (with-meta 283 | (apply list 284 | (map (fn [e] 285 | (track config results-atom e (extend-paths paths (seq-entry)) 286 | call-ids)) 287 | v)) 288 | (meta v))] 289 | (assert (list? res)) 290 | res)) 291 | 292 | (and (seq? v) 293 | (not (list? v))) 294 | (let [[paths unwrapped-seq paths-where-original-coll-could-be-empty] 295 | (if (-> v meta ::wrapped-seq?) 296 | ((juxt ::paths ::unwrapped-seq ::paths-where-original-coll-could-be-empty) 297 | ;; combine paths 298 | (-> (meta v) 299 | (update ::paths into paths) 300 | (update ::paths-where-original-coll-could-be-empty into paths))) 301 | [paths v paths]) 302 | _ (assert (set? paths)) 303 | ;; space-efficient wrapping 304 | wrap-lseq 305 | (fn wrap-lseq [unwrapped-seq paths-where-original-coll-could-be-empty] 306 | (with-meta 307 | (lazy-seq 308 | (if (empty? unwrapped-seq) 309 | (let [] 310 | (when (seq paths-where-original-coll-could-be-empty) 311 | (add-infer-results! 312 | results-atom 313 | (infer-results 314 | paths-where-original-coll-could-be-empty 315 | (-class :seq [-nothing])))) 316 | unwrapped-seq) 317 | (cons (track config results-atom 318 | (first unwrapped-seq) 319 | (extend-paths paths (seq-entry)) 320 | call-ids) 321 | (wrap-lseq (rest unwrapped-seq) 322 | ;; collection can no longer be empty for these paths 323 | #{})))) 324 | (merge (meta unwrapped-seq) 325 | {::wrapped-seq? true 326 | ::paths-where-original-coll-could-be-empty paths-where-original-coll-could-be-empty 327 | ::paths paths 328 | ::unwrapped-seq unwrapped-seq})))] 329 | (wrap-lseq unwrapped-seq paths-where-original-coll-could-be-empty)) 330 | 331 | (instance? #?(:clj clojure.lang.ITransientVector :cljs TransientVector) v) 332 | (let [cnt (count v)] 333 | (reduce 334 | (fn [v i] 335 | (let [e (nth v i) 336 | e' (track config results-atom e 337 | (extend-paths paths (transient-vector-entry)) 338 | call-ids)] 339 | (if (identical? e e') 340 | v 341 | (binding [*should-track* false] 342 | (assoc! v i e'))))) 343 | v 344 | (range cnt))) 345 | 346 | ;; cover map entries 347 | (and (vector? v) 348 | (= 2 (count v))) 349 | (let [k (track config results-atom (nth v 0) (extend-paths paths (index-path 2 0)) call-ids) 350 | vl (track config results-atom (nth v 1) (extend-paths paths (index-path 2 1)) call-ids)] 351 | (assoc v 0 k 1 vl)) 352 | 353 | (vector? v) 354 | (let [heterogeneous? (<= (count v) 4) 355 | len (count v) 356 | so-far (atom 0)] 357 | (when (= 0 len) 358 | (add-infer-results! results-atom (infer-results paths (-class :vector [-nothing])))) 359 | (reduce 360 | (fn [e [k v]] 361 | (swap! so-far inc) 362 | (let [v' (track config results-atom v (extend-paths 363 | paths 364 | (if heterogeneous? 365 | (index-path len k) 366 | (vec-entry-path))) 367 | call-ids)] 368 | (cond 369 | (when-let [tc track-count] 370 | (< tc @so-far)) 371 | (reduced (binding [*should-track* false] 372 | (assoc e k v'))) 373 | 374 | (identical? v v') e 375 | :else 376 | (binding [*should-track* false] 377 | (assoc e k v'))))) 378 | v 379 | (map-indexed vector v))) 380 | 381 | (set? v) 382 | (do 383 | (when (empty? v) 384 | (add-infer-results! 385 | results-atom 386 | (infer-results paths 387 | (-class :set [-nothing])))) 388 | ;; preserve sorted sets 389 | (binding [*should-track* false] 390 | (into (empty v) 391 | (map (fn [e] 392 | (binding [*should-track* true] 393 | (track config results-atom e (extend-paths paths (set-entry)) 394 | call-ids)))) 395 | v))) 396 | 397 | #?(:clj (instance? PersistentMapProxy v)) 398 | #?(:clj 399 | (let [^PersistentMapProxy v v 400 | ks (.current-ks v) 401 | _ (assert (set? ks)) 402 | all-kws? (.current-all-kws? v) 403 | _ (assert (boolean? all-kws?)) 404 | kw-entries-types (.current-kw-entries-types v) 405 | _ (assert (map? kw-entries-types)) 406 | track-info {:all-kws? all-kws? 407 | :ks ks 408 | :kw-entries-types kw-entries-types}] 409 | ;; TODO do we update the config/results-atom? What if they're different than the proxy's? 410 | (PersistentMapProxy. (.m v) 411 | (reduce (fn [m k] 412 | (update-in m [k track-info] 413 | #(merge-with (fnil into #{}) 414 | % 415 | {:paths paths 416 | :call-ids call-ids}))) 417 | (.k-to-track-info v) 418 | ;; FIXME we should remove known kw entries 419 | ks) 420 | (.config v) 421 | (.results-atom v) 422 | (.current-kw-entries-types v) 423 | (.current-ks v) 424 | (.current-all-kws? v)))) 425 | 426 | #?(:clj 427 | (or (instance? clojure.lang.PersistentHashMap v) 428 | (instance? clojure.lang.PersistentArrayMap v) 429 | (instance? clojure.lang.PersistentTreeMap v)) 430 | :cljs (map? v)) 431 | (let [ks (set (keys v))] 432 | (when (empty? v) 433 | (add-infer-results! 434 | results-atom 435 | (infer-results paths (make-HMap {} {})))) 436 | (cond 437 | (every? keyword? ks) 438 | (let [{with-kw-val true 439 | no-kw-val false} 440 | (binding [*should-track* false] 441 | (group-by (fn [e] 442 | (keyword? (val e))) 443 | v)) 444 | kw-entries-types 445 | (into {} 446 | (map (fn [[k v]] 447 | {:pre [(keyword? v)]} 448 | [k (-val v)])) 449 | with-kw-val) 450 | ;; we rely on the no-kw-val map to 451 | ;; track the simple keyword entries -- if there 452 | ;; are none, just pick one of the kw-entries-types 453 | ;; and track it. 454 | _ (when (and (empty? no-kw-val) 455 | (seq kw-entries-types)) 456 | (let [k (key (first kw-entries-types))] 457 | (track config results-atom (get v k) 458 | (binding [*should-track* false] 459 | (extend-paths paths (key-path kw-entries-types ks k))) 460 | call-ids))) 461 | v #?(:cljs v 462 | :clj (if (= track-strategy :lazy) 463 | (PersistentMapProxy. v 464 | (zipmap (apply disj ks with-kw-val) 465 | (repeat {{:all-kws? true 466 | :kw-entries-types kw-entries-types 467 | :ks ks} 468 | {:paths paths 469 | :call-ids call-ids}})) 470 | config 471 | results-atom 472 | kw-entries-types 473 | ks 474 | true) 475 | v))] 476 | (reduce 477 | (fn [m [k orig-v]] 478 | (let [v (track config results-atom orig-v 479 | (binding [*should-track* false] 480 | (extend-paths paths (key-path kw-entries-types ks k))) 481 | call-ids)] 482 | (cond 483 | ;; only assoc if needed 484 | (identical? v orig-v) m 485 | 486 | :else 487 | (binding [*should-track* false] 488 | (assoc m k v))))) 489 | v 490 | no-kw-val)) 491 | 492 | :else 493 | (let [so-far (atom 0) 494 | v #?(:cljs v 495 | :clj (if (= track-strategy :lazy) 496 | (PersistentMapProxy. v 497 | (zipmap ks (repeat {{:all-kws? false 498 | :kw-entries-types {} 499 | :ks ks} 500 | {:paths paths 501 | :call-ids call-ids}})) 502 | config 503 | results-atom 504 | {} 505 | ks 506 | false) 507 | v))] 508 | (reduce 509 | (fn [m k] 510 | (swap! so-far inc) 511 | (let [orig-v (get m k) 512 | [new-k v] 513 | (cond 514 | ;; We don't want to pollute the HMap-req-ks with 515 | ;; non keywords (yet), disable. 516 | ;(keyword? k) 517 | ;[k (track config results-atom orig-v 518 | ; (binding [*should-track* false] 519 | ; (extend-paths paths (key-path {} ks k))))] 520 | 521 | :else 522 | [(track config results-atom k 523 | (binding [*should-track* false] 524 | (extend-paths paths (map-keys-path))) 525 | call-ids) 526 | (track config results-atom orig-v 527 | (binding [*should-track* false] 528 | (extend-paths paths (map-vals-path))) 529 | call-ids)])] 530 | (cond 531 | ; cut off homogeneous map 532 | (when-let [tc *track-count*] 533 | (< tc @so-far)) 534 | (reduced 535 | (binding [*should-track* false] 536 | (-> m 537 | ;; ensure we replace the key 538 | (dissoc k) 539 | (assoc new-k v)))) 540 | 541 | ;; only assoc if needed 542 | (identical? v orig-v) m 543 | 544 | ;; make sure we replace the key 545 | (not (identical? new-k k)) 546 | (binding [*should-track* false] 547 | (-> m 548 | (dissoc k) 549 | (assoc new-k v))) 550 | 551 | :else 552 | (binding [*should-track* false] 553 | (assoc m new-k v))))) 554 | v 555 | (keys v))))) 556 | 557 | (instance? #?(:clj clojure.lang.IAtom :cljs Atom) v) 558 | (let [old-val (-> v meta :clojure.core.typed/old-val) 559 | new-paths (binding [*should-track* false] 560 | (extend-paths paths (atom-contents))) 561 | should-track? (binding [*should-track* false] 562 | (not= @v old-val)) 563 | _ (when should-track? 564 | (track config results-atom @v new-paths 565 | call-ids)) 566 | #_#_ 567 | _ (binding [*should-track* false] 568 | (add-watch 569 | v 570 | new-paths 571 | (fn [_ _ _ new] 572 | (binding [*should-track* true] 573 | (track config results-atom new new-paths 574 | call-ids)))))] 575 | v) 576 | 577 | :else (do 578 | (add-infer-results! results-atom (infer-results paths (-class (classify v) []))) 579 | v))))) 580 | 581 | (declare gen-track-config) 582 | 583 | #?(:cljs 584 | (defn track-cljs-val [v root] 585 | (track (gen-track-config) 586 | results-atom 587 | v 588 | #{[(var-path 589 | 'root 590 | root)]} 591 | #{}))) 592 | 593 | #?(:clj 594 | (def prim-invoke-interfaces 595 | (into #{} 596 | (->> 597 | (map (fn [ss] (apply str ss)) 598 | (apply concat 599 | (for [n (range 1 6)] 600 | (apply comb/cartesian-product (repeat n [\D \O \L]))))) 601 | (remove (fn [ss] 602 | (every? #{\O} ss))))))) 603 | 604 | #?(:clj 605 | (defn char->tag [c] 606 | {:pre [(char? c)] 607 | :post [(symbol? %)]} 608 | (case c 609 | \L 'long 610 | \D 'double 611 | \O 'java.lang.Object))) 612 | 613 | #?(:clj 614 | (defn tag->char [t] 615 | {:pre [((some-fn nil? symbol?) t)] 616 | :post [(char? %)]} 617 | (case t 618 | long \L 619 | double \D 620 | \O))) 621 | 622 | #?(:clj 623 | (defn gen-prim-invokes [f-this prims] 624 | ;(prn "gen-prim-invokes" prims) 625 | (mapcat 626 | (fn [p] 627 | {:pre [(string? p)]} 628 | (let [args (into [] 629 | (map-indexed 630 | (fn [n c] 631 | (-> (symbol (str "arg" n)) 632 | #_(vary-meta 633 | assoc :tag (char->tag c))))) 634 | (butlast p)) 635 | interface (symbol (str "clojure.lang.IFn$" p)) 636 | rettag (char->tag (nth p (dec (count p)))) 637 | ;_ (prn "rettag" rettag) 638 | this (gensym 'this) 639 | argvec (-> (vec (cons this args)) 640 | #_(vary-meta assoc :tag rettag))] 641 | #_ 642 | (binding [*print-meta* true] 643 | (prn "argvec" argvec)) 644 | [interface 645 | (list 'invokePrim argvec 646 | `(~(f-this this) ~@(map #(with-meta % nil) args)))])) 647 | prims))) 648 | 649 | #?(:clj 650 | (defn gen-nonvariadic-invokes [f-this] 651 | (for [arity (range 0 20), 652 | :let [args (repeatedly arity gensym) 653 | this (gensym 'this)]] 654 | `(~'invoke [~this ~@args] 655 | (~(f-this this) ~@args))))) 656 | 657 | #?(:clj 658 | (defn gen-variadic-invoke [f-this] 659 | (let [args (repeatedly 21 gensym) 660 | this (gensym 'this)] 661 | `(~'invoke [~this ~@args] (apply ~(f-this this) ~@args))))) 662 | 663 | #?(:clj 664 | (defn gen-apply-to [f-this] 665 | (let [this (gensym 'this)] 666 | `(~'applyTo [~this args#] (apply ~(f-this this) args#))))) 667 | 668 | #?(:clj 669 | (defn extend-IFn [f-this prims] 670 | `(clojure.lang.IFn 671 | ~@(gen-nonvariadic-invokes f-this) 672 | ~(gen-variadic-invoke f-this) 673 | ~(gen-apply-to f-this) 674 | ~@(gen-prim-invokes f-this prims)))) 675 | 676 | #?(:clj 677 | (defmacro deftypefn 678 | "Like deftype, but accepts a function f before any specs that is 679 | used to implement clojure.lang.IFn. f should accept at least one 680 | argument, 'this'." 681 | [name prims & opts+specs] 682 | (let [field 'f 683 | f-this (fn [this] 684 | (list '. this (symbol (str "-" field)))) 685 | source `(deftype ~name [~field] 686 | ~@(extend-IFn f-this prims) 687 | ~@opts+specs)] 688 | #_ 689 | (binding [*print-meta* true] 690 | (pprint source)) 691 | source))) 692 | 693 | #?(:clj 694 | (def this-ns *ns*)) 695 | 696 | #?(:clj 697 | (defn arglist-prim-string [args] 698 | {:pre [(vector? args)] 699 | :post [((some-fn nil? string?) %)]} 700 | (let [s (apply str 701 | (concat 702 | (->> args 703 | (map (comp :tag meta)) 704 | (map tag->char)) 705 | [(tag->char (-> args meta :tag))]))] 706 | (when (prim-invoke-interfaces s) 707 | s)))) 708 | 709 | #?(:clj 710 | (defn wrap-prim [vr f] 711 | {:pre [(var? vr)]} 712 | ;(prn "wrap-prim" vr) 713 | (let [prim-arglists 714 | (sort 715 | (->> (-> vr meta :arglists) 716 | (map arglist-prim-string) 717 | (filter string?)))] 718 | (cond 719 | (seq prim-arglists) 720 | (let [type-name (symbol 721 | (str "PrimFn" 722 | (apply str 723 | (interpose 724 | "_" 725 | prim-arglists)))) 726 | ;_ (prn "type-name" type-name) 727 | cls (or #_(ns-resolve this-ns type-name) 728 | (binding [*ns* this-ns] 729 | (eval 730 | `(deftypefn ~type-name ~prim-arglists)))) 731 | _ (assert (class? cls)) 732 | ctor (ns-resolve this-ns 733 | (symbol 734 | (str "->" type-name))) 735 | _ (assert (var? ctor))] 736 | (ctor f)) 737 | 738 | :else f)))) 739 | 740 | (defn gen-track-config [] 741 | (merge 742 | {:track-strategy :lazy 743 | :track-depth *track-depth* 744 | :track-count *track-count* 745 | :root-results *root-results*} 746 | vs/*instrument-infer-config*)) 747 | 748 | ; track-var : (IFn [Var -> Value] [(Atom Result) Var Sym -> Value]) 749 | #?(:clj 750 | (defn track-var' 751 | ([vr] (track-var' (gen-track-config) results-atom vr *ns*)) 752 | ([config vr] (track-var' config results-atom vr *ns*)) 753 | ([config results-atom vr ns] 754 | {:pre [(var? vr) 755 | (instance? #?(:clj clojure.lang.IAtom :cljs Atom) results-atom)]} 756 | ;(prn "tracking" vr "in ns" ns) 757 | (wrap-prim 758 | vr 759 | (track config 760 | results-atom @vr #{[(var-path 761 | (ns-name (the-ns ns)) 762 | (impl/var->symbol vr))]} 763 | #{}))))) 764 | 765 | #?(:clj 766 | (defmacro track-var [v] 767 | `(track-var' (var ~v)))) 768 | 769 | ; track-def-init : Sym Sym Value -> Value 770 | #?(:clj 771 | (defn track-def-init [config vsym ns val] 772 | {:pre [(symbol? vsym) 773 | (namespace vsym)]} 774 | ;(prn "track-def-init") 775 | (let [v (ns-resolve ns vsym)] 776 | ;(prn v) 777 | (wrap-prim 778 | v 779 | (track config 780 | results-atom val 781 | #{[{:op :var 782 | :ns (ns-name ns) 783 | :name vsym}]} 784 | #{}))))) 785 | 786 | #?(:clj 787 | (defn track-local-fn [config track-kind line column end-line end-column ns val] 788 | {:pre [(#{:local-fn :loop-var} track-kind)]} 789 | #_ 790 | (prn "track-local-fn" 791 | (symbol 792 | (str (ns-name ns) 793 | "|" 794 | line 795 | "|" 796 | column 797 | "|" 798 | end-line 799 | "|" 800 | end-column))) 801 | (track config 802 | results-atom val 803 | #{[{:op :var 804 | :clojure.core.typed.annotator.track/track-kind track-kind 805 | :line line 806 | :column column 807 | :end-line end-line 808 | :end-column end-column 809 | :ns (ns-name ns) 810 | :name (with-meta 811 | (symbol 812 | (str (ns-name ns) 813 | "|" 814 | line 815 | "|" 816 | column 817 | "|" 818 | end-line 819 | "|" 820 | end-column)) 821 | {:clojure.core.typed.annotator.track/track-kind track-kind 822 | :line line 823 | :column column 824 | :end-line end-line 825 | :end-column end-column 826 | :ns (ns-name ns)})}]} 827 | #{}))) 828 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/annotator/frontend/spec.cljc: -------------------------------------------------------------------------------- 1 | (ns clojure.core.typed.annotator.frontend.spec 2 | (:require [clojure.core.typed.annotator.util 3 | :refer [qualify-spec-symbol kw-val? nil-val? 4 | *preserve-unknown* 5 | qualify-core-symbol 6 | kw->sym 7 | list*-force 8 | current-ns 9 | *used-aliases* 10 | *multispecs-needed* 11 | *envs* 12 | fully-resolve-alias 13 | HMap-likely-tag-key 14 | alias-env 15 | *forbidden-aliases* 16 | find-top-level-var 17 | arglists-for-top-level-var 18 | separate-fixed-from-rest-arglists 19 | core-specs-ns 20 | uniquify 21 | resolve-alias 22 | gen-unique-alias-name 23 | macro-symbol? 24 | imported-symbol? 25 | update-type-env 26 | update-alias-env 27 | register-alias 28 | kw-vals? 29 | type-env 30 | ]] 31 | [clojure.core.typed.annotator.join :refer [make-Union join]] 32 | [clojure.core.typed.annotator.track :refer [local-fn-symbol?]] 33 | [clojure.core :as core] 34 | [clojure.core.typed.annotator.rep :as r] 35 | )) 36 | 37 | (def ^:dynamic *higher-order-fspec* nil) 38 | 39 | (defn unq-spec-nstr [] (str (current-ns))) 40 | 41 | (declare unparse-spec') 42 | 43 | (defn gen-unique-multi-spec-name [env multispecs sym] 44 | (if (or #?(:clj (resolve sym)) 45 | (contains? multispecs sym)) 46 | (gen-unique-multi-spec-name env multispecs (symbol (str (name sym) "__0"))) 47 | sym)) 48 | 49 | (defn simplify-spec-alias [a] 50 | {:pre [(r/type? a)] 51 | :post [(r/type? %)]} 52 | (if (r/alias? a) 53 | (let [a-res (resolve-alias @*envs* a)] 54 | (if (and a-res (#{:class} (:op a-res))) 55 | a-res 56 | a)) 57 | a)) 58 | 59 | (defn unparse-spec [m] 60 | (unparse-spec' m)) 61 | 62 | (defn alias->spec-kw [s] 63 | {:pre [(symbol? s)] 64 | :post [(keyword? %)]} 65 | (if (namespace s) 66 | (keyword s) 67 | (keyword (name (current-ns)) (name s)))) 68 | 69 | (defn spec-star [arg] 70 | (list (qualify-spec-symbol '*) arg)) 71 | 72 | (defn spec-cat [args] 73 | (assert (even? (count args))) 74 | (list*-force (qualify-spec-symbol 'cat) args)) 75 | 76 | ;; Answers: is this a good alias to generate `s/keys`? 77 | (defn alias-matches-key-for-spec-keys? [a k] 78 | {:pre [(r/alias? a) 79 | (keyword? k)]} 80 | (if (namespace k) 81 | (= (:name a) (kw->sym k)) 82 | (= (name (:name a)) (name k)))) 83 | 84 | (declare or-spec) 85 | 86 | (defn unparse-spec' [{:as m}] 87 | (assert (r/type? m) m) 88 | (case (:op m) 89 | :alias (do 90 | (when-let [used-aliases *used-aliases*] 91 | (swap! used-aliases conj (:name m))) 92 | (alias->spec-kw (:name m))) 93 | :val (let [t (:val m)] 94 | (cond 95 | (:clojure.core.typed.annotator.frontend.spec/implicit-alias m) (unparse-spec (:clojure.core.typed.annotator.frontend.spec/implicit-alias m)) 96 | (nil? t) (qualify-core-symbol 'nil?) 97 | (false? t) (qualify-core-symbol 'false?) 98 | (keyword? t) #{t} #_(qualify-core-symbol 'keyword?) 99 | (string? t) (qualify-core-symbol 'string?) 100 | :else (qualify-core-symbol 'any?))) 101 | :union (if (:clojure.core.typed.annotator.frontend.spec/implicit-alias m) 102 | (unparse-spec (:clojure.core.typed.annotator.frontend.spec/implicit-alias m)) 103 | (let [env *envs* 104 | fully-res (if env 105 | #(fully-resolve-alias @env %) 106 | identity) 107 | ts (map fully-res (:types m))] 108 | (if-let [tag (and env 109 | (every? r/HMap? ts) 110 | (HMap-likely-tag-key ts))] 111 | ;; if we have a bunch of maps with a similar key, 112 | ;; generate a multispec 113 | (let [multispecs *multispecs-needed* 114 | _ (assert multispecs) 115 | _ (assert (map? @multispecs)) 116 | nme (gen-unique-multi-spec-name 117 | env @multispecs 118 | (symbol (str (when-let [nstr (namespace tag)] 119 | (str nstr "-")) 120 | (name tag) "-multi-spec"))) 121 | dmulti (list 122 | (qualify-core-symbol 'defmulti) 123 | (with-meta nme 124 | {::generated true}) 125 | tag) 126 | tag-for-hmap (fn [t] 127 | {:pre [(r/HMap? t)]} 128 | (let [this-tag (get (:clojure.core.typed.annotator.rep/HMap-req t) tag) 129 | _ (assert (kw-val? this-tag) (unparse-spec t))] 130 | (:val this-tag))) 131 | dmethods (mapv (fn [t] 132 | {:pre [(r/HMap? t)]} 133 | (let [this-tag (tag-for-hmap t)] 134 | (list (qualify-core-symbol 'defmethod) 135 | nme 136 | this-tag 137 | ['_] 138 | (unparse-spec t)))) 139 | (sort-by tag-for-hmap ts)) 140 | _ (when multispecs 141 | (swap! multispecs assoc nme (vec (cons dmulti dmethods))))] 142 | (list (qualify-spec-symbol 'multi-spec) 143 | nme 144 | tag)) 145 | (or-spec (:types m))))) 146 | :HVec (list* (qualify-spec-symbol 'tuple) 147 | (mapv unparse-spec (:vec m))) 148 | :HMap (let [specify-keys 149 | (fn [entries] 150 | (->> entries 151 | (map (fn [[k v]] 152 | {:pre [(keyword? k)]} 153 | (let [a (or (when (r/alias? v) v) 154 | (:clojure.core.typed.annotator.frontend.spec/implicit-alias v))] 155 | (assert (and (r/alias? a) 156 | (alias-matches-key-for-spec-keys? a k)) 157 | [k (:op v)]) 158 | (unparse-spec a)))) 159 | sort 160 | vec)) 161 | group-by-qualified #(group-by (comp boolean namespace key) %) 162 | {req true req-un false} (group-by-qualified (:clojure.core.typed.annotator.rep/HMap-req m)) 163 | {opt true opt-un false} (group-by-qualified (:clojure.core.typed.annotator.rep/HMap-opt m))] 164 | (list* (qualify-spec-symbol 'keys) 165 | (concat 166 | (when (seq req) 167 | [:req (specify-keys req)]) 168 | (when (seq opt) 169 | [:opt (specify-keys opt)]) 170 | (when (seq req-un) 171 | [:req-un (specify-keys req-un)]) 172 | (when (seq opt-un) 173 | [:opt-un (specify-keys opt-un)])))) 174 | :IFn (let [{:keys [arities top-level-def]} m 175 | top-level-var (find-top-level-var top-level-def) 176 | ;_ (prn "top-level-var" top-level-def top-level-var) 177 | arglists (arglists-for-top-level-var top-level-var) 178 | ;_ (prn "arglists" arglists) 179 | macro? (some-> top-level-var meta :macro) 180 | {fixed-arglists :fixed [rest-arglist] :rest} (separate-fixed-from-rest-arglists arglists) 181 | _ (assert ((some-fn nil? (every-pred vector? #(<= 2 (count %)))) rest-arglist)) 182 | ;; expand varargs into extra fixed arguments 183 | fixed-arglists (into (or fixed-arglists []) 184 | (when rest-arglist 185 | (let [fixed-arg-nums (into #{} (map count) fixed-arglists) 186 | fixed (subvec rest-arglist 0 (- (count rest-arglist) 2)) 187 | rst-arg (peek rest-arglist) 188 | extra-fixed (if (vector? rst-arg) 189 | (vec (take-while (complement #{'& :as}) rst-arg)) 190 | [])] 191 | (->> (map #(into fixed (subvec extra-fixed 0 %)) (range (inc (count extra-fixed)))) 192 | ;; prefer actual fixed arguments over derived ones 193 | (remove (comp fixed-arg-nums count)))))) 194 | ;_ (prn "fixed-arglists" fixed-arglists) 195 | ;_ (prn "rest-arglist" rest-arglist) 196 | ;; map from arity length to vector of fixed arguments 197 | fixed-name-lookup (into {} 198 | (map (fn [v] 199 | [(count v) v])) 200 | fixed-arglists)] 201 | ;(prn "fixed-name-lookup" fixed-name-lookup) 202 | (cond 203 | ;; erase higher-order function arguments by default, 204 | ;; use *higher-order-fspec* to leave as fspecs. 205 | ; It's also important that we don't unparse specs 206 | ; we don't use so we don't create garbage aliases, so 207 | ; this must go first. 208 | (not (or top-level-var *higher-order-fspec*)) 209 | (qualify-core-symbol 'ifn?) 210 | 211 | :else 212 | (let [;; if we have a macro, ignore the first two arguments 213 | ;; in each arity (&env and &form) 214 | arities (if macro? 215 | (map (fn [a] 216 | (update a :dom (fn [dom] 217 | (if (<= 2 (count dom)) 218 | (subvec dom 2) 219 | dom)))) 220 | arities) 221 | arities) 222 | doms (cond 223 | macro? 224 | [(spec-cat 225 | (concat 226 | ;; macros are very likely to having binding 227 | ;; forms as the first argument if it's always 228 | ;; a vector. 229 | (when (every? (fn [{:keys [dom]}] 230 | ;; every first argument is a vector 231 | (let [[d] dom] 232 | (when d 233 | (and 234 | (#{:class} (:op d)) 235 | (= :vector 236 | (:clojure.core.typed.annotator.rep/class-instance d)))))) 237 | arities) 238 | [:bindings (keyword (str core-specs-ns) "bindings")]) 239 | ;; if there is more than one arity, 240 | ;; default to a rest argument. 241 | [:body 242 | (if (<= 2 (count arities)) 243 | (list (qualify-spec-symbol '*) 244 | (qualify-core-symbol 'any?)) 245 | (qualify-core-symbol 'any?))]))] 246 | :else 247 | (mapv 248 | (fn [{:keys [dom] :as ifn}] 249 | {:pre [dom]} 250 | ;(prn "doms" (count dom) (keyword (get fixed-name-lookup (count dom)))) 251 | (let [dom-knames 252 | (let [[matching-fixed-names rest-arg-name] 253 | (or (when-let [f (get fixed-name-lookup (count dom))] 254 | [f nil]) 255 | (when rest-arglist 256 | (assert (vector? rest-arglist)) 257 | (when (>= (count dom) (dec (count rest-arglist))) 258 | [(subvec rest-arglist 0 (- (count rest-arglist) 2)) 259 | (peek rest-arglist)]))) 260 | keywordify-arg 261 | (fn [arg] 262 | ;; here we can improve naming by examining destructuring 263 | (cond 264 | ;; simple argument name 265 | (symbol? arg) (keyword (namespace arg) (name arg)) 266 | 267 | ;; {:as foo} map destructuring 268 | (and (map? arg) 269 | (symbol? (:as arg))) 270 | (keyword (namespace (:as arg)) 271 | (name (:as arg))) 272 | 273 | ;; [:as foo] vector destructuring 274 | (and (vector? arg) 275 | (<= 2 (count arg)) 276 | (#{:as} (nth arg (- (count arg) 2))) 277 | (symbol? (peek arg))) 278 | (keyword (namespace (peek arg)) 279 | (name (peek arg))))) 280 | combined-kws 281 | (let [fixed-kws (map-indexed (fn [n arg] 282 | (or (keywordify-arg arg) 283 | (let [s (or #_(some-> top-level-def name) 284 | "arg")] 285 | (keyword (str s "-" n))))) 286 | matching-fixed-names) 287 | rest-kws (when rest-arg-name 288 | (let [dom-remain (- (count dom) (count fixed-kws)) 289 | kw-arg (keywordify-arg rest-arg-name) 290 | prefix (if kw-arg 291 | (str (when-let [n (namespace kw-arg)] 292 | (str n "/")) 293 | (name kw-arg)) 294 | (str "rest-arg"))] 295 | (map (fn [n] 296 | (keyword (str prefix "-" n))) 297 | (range dom-remain)))) 298 | combined-kws (vec (uniquify (concat fixed-kws rest-kws)))] 299 | (if (= (count dom) (count combined-kws)) 300 | combined-kws 301 | (mapv (fn [n] (keyword (str "arg-" n))) 302 | (range (count dom)))))] 303 | (assert (= (count dom) (count combined-kws))) 304 | combined-kws)] 305 | (spec-cat 306 | (concat 307 | (mapcat (fn [n k d] 308 | {:pre [(keyword? k)]} 309 | (let [spec 310 | (cond 311 | (and (zero? n) 312 | macro? 313 | (#{:class} (:op d)) 314 | (= :vector 315 | (:clojure.core.typed.annotator.rep/class-instance d))) 316 | (keyword (str core-specs-ns) "bindings") 317 | 318 | :else (unparse-spec d))] 319 | [k spec])) 320 | (range) 321 | dom-knames 322 | dom) 323 | (when-let [rest (:rest ifn)] 324 | [(or (when-let [[_ n] (seq rest-arglist)] 325 | (when (symbol? n) 326 | (keyword (name n)))) 327 | :rest-arg) 328 | (spec-star (unparse-spec rest))]))))) 329 | arities)) 330 | rngs (if macro? 331 | (qualify-core-symbol 'any?) 332 | (or-spec (let [u (make-Union (map :rng arities))] 333 | (if (r/union? u) 334 | (:types u) 335 | [u])))) 336 | dom-specs (if (= 1 (count doms)) 337 | (first doms) 338 | (list* (qualify-spec-symbol 'alt) ;; use alt to treat args as flat sequences 339 | (let [named-alts (map (fn [alt] 340 | (let [kw (keyword (let [n (/ (dec (count alt)) 2)] 341 | (str n (or (when (= 1 n) 342 | "-arg") 343 | "-args"))))] 344 | [kw alt])) 345 | doms)] 346 | (apply concat (sort-by first named-alts)))))] 347 | (list* (qualify-spec-symbol 'fspec) 348 | [:args dom-specs 349 | :ret rngs])))) 350 | :class (let [cls (:clojure.core.typed.annotator.rep/class-instance m) 351 | args (:args m)] 352 | (cond 353 | (#{:int} cls) (qualify-core-symbol 'int?) 354 | (#{:integer} cls) (qualify-core-symbol 'integer?) 355 | (#{:decimal} cls) (qualify-core-symbol 'decimal?) 356 | (#{:double} cls) (qualify-core-symbol 'double?) 357 | (#{:number} cls) (qualify-core-symbol 'number?) 358 | (#{:char} cls) (qualify-core-symbol 'char?) 359 | (#{:symbol} cls) (qualify-core-symbol 'symbol?) 360 | (#{:keyword} cls) (qualify-core-symbol 'keyword?) 361 | (#{:string} cls) (qualify-core-symbol 'string?) 362 | (#{:ifn} cls) (qualify-core-symbol 'ifn?) 363 | (#{:boolean} cls) (qualify-core-symbol 'boolean?) 364 | ;; TODO check set elements 365 | (#{:set} cls) (qualify-core-symbol 'set?) 366 | (#{:map} cls) 367 | ;; NOTE if we change the `empty?` specs here, also update 368 | ;; `or-spec` tag generation. 369 | (if (some r/nothing? args) 370 | (list (qualify-spec-symbol 'and) 371 | (qualify-core-symbol 'empty?) 372 | (qualify-core-symbol 'map?)) 373 | (let [[k v] args] 374 | (list (qualify-spec-symbol 'map-of) 375 | (unparse-spec k) 376 | (unparse-spec v)))) 377 | (#{:vector :coll :seq} cls) 378 | (if (r/nothing? (first args)) 379 | (list (qualify-spec-symbol 'and) 380 | (qualify-core-symbol 'empty?) 381 | (qualify-core-symbol 'coll?)) 382 | (list*-force 383 | (qualify-spec-symbol 'coll-of) 384 | (unparse-spec 385 | (first args)) 386 | (when (#{:vector} cls) 387 | [:into (qualify-core-symbol 'vector?)]))) 388 | 389 | :else (do 390 | (assert (string? cls)) 391 | (list (qualify-core-symbol 'partial) 392 | (qualify-core-symbol 'instance?) 393 | (symbol cls))))) 394 | :Top (qualify-core-symbol 'any?) 395 | :unknown (cond 396 | *preserve-unknown* '? 397 | :else (qualify-core-symbol 'any?)) 398 | :free (alias->spec-kw (:name m)) 399 | (assert nil (str "No unparse-type case: " m)))) 400 | 401 | (defn def-spec [k s] 402 | (list (qualify-spec-symbol 'def) 403 | k 404 | ; handle possibly recursive specs 405 | ; TODO intelligently order specs to minimize this issue 406 | (if (or (symbol? s) 407 | (set? s) 408 | ;; already late bound 409 | (and (seq? s) 410 | (let [fs (first s)] 411 | ((into #{} 412 | (map qualify-spec-symbol) 413 | ; late binding ops 414 | '[and keys cat alt or nilable coll-of 415 | fspec map-of tuple cat multi-spec 416 | *]) 417 | fs)))) 418 | s 419 | (list (qualify-spec-symbol 'and) 420 | s)))) 421 | 422 | ;; generate good alias name for `s/keys` 423 | (defn register-unique-alias-for-spec-keys [env config k t] 424 | {:pre [(keyword? k) 425 | (r/type? t)] 426 | :post [(namespace (first %))]} 427 | (let [qualified? (boolean (namespace k)) 428 | sym (if qualified? 429 | (kw->sym k) 430 | ;; not a truly unique namespace prefix, but let's see if it 431 | ;; works in practice. 432 | (symbol (unq-spec-nstr) (name k)))] 433 | ;(prn "register" sym) 434 | [sym (if true #_qualified? 435 | (update-alias-env env update sym #(if %1 (join %1 %2) %2) t) 436 | (register-alias env config sym t))])) 437 | 438 | (defn or-spec [alts] 439 | {:pre [(every? r/type? alts)]} 440 | (let [;; put instance comparisons at the front of the disjunction. 441 | ;; avoid errors in checking specs that have both records 442 | ;; and collections, since records do not implement `empty`. 443 | {inst? true other false} (group-by (fn [t] 444 | (boolean 445 | (or (#{:val} (:op t)) 446 | (and (#{:class} (:op t)) 447 | (not 448 | (#{:set 449 | :map 450 | :vector 451 | :coll 452 | :seq} 453 | (:clojure.core.typed.annotator.rep/class-instance t))))))) 454 | alts)] 455 | ;(prn "or-spec" alts) 456 | (cond 457 | (and (seq alts) 458 | (every? kw-val? alts)) 459 | (into #{} (map :val alts)) 460 | 461 | (and (= 2 (count (set alts))) 462 | (some nil-val? alts) 463 | (some (complement nil-val?) alts)) 464 | (list (qualify-spec-symbol 'nilable) 465 | (unparse-spec (first (remove nil-val? alts)))) 466 | 467 | :else 468 | (let [specs (into {} 469 | (map (fn [alt] 470 | [(unparse-spec alt) alt])) 471 | (concat (set inst?) (set other)))] 472 | (if (= 1 (count specs)) 473 | (unparse-spec (simplify-spec-alias (second (first specs)))) 474 | (list*-force (qualify-spec-symbol 'or) 475 | (let [names (map 476 | (fn [[s orig]] 477 | {:pre [(core/any? s) 478 | (r/type? orig)] 479 | :post [(keyword? %)]} 480 | ;; we can enhance the naming for s/or tags here 481 | (or ;; probably a predicate 482 | (when (symbol? s) 483 | (keyword (name s))) 484 | ;; a spec alias 485 | (when (keyword? s) 486 | (keyword (name s))) 487 | ;; literal keywords 488 | (when (and (set? s) 489 | (every? keyword? s)) 490 | :kw) 491 | ;; an instance check 492 | (when (and (seq? s) 493 | (= (count s) 3) 494 | (= (first s) (qualify-core-symbol 'partial)) 495 | (= (second s) (qualify-core-symbol 'instance?)) 496 | (symbol? (nth s 2))) 497 | (keyword (name (nth s 2)))) 498 | ;; a coll-of 499 | (when (and (seq? s) 500 | (>= (count s) 2) 501 | (= (first s) (qualify-spec-symbol 'coll-of))) 502 | :coll) 503 | ;; a map-of 504 | (when (and (seq? s) 505 | (>= (count s) 3) 506 | (= (first s) (qualify-spec-symbol 'map-of))) 507 | :map) 508 | ;; a tuple 509 | (when (and (seq? s) 510 | (>= (count s) 1) 511 | (= (first s) (qualify-spec-symbol 'tuple))) 512 | :tuple) 513 | ;; an empty thing 514 | (when (and (seq? s) 515 | (>= (count s) 3) 516 | (let [[c1 c2 c3] s] 517 | (= c1 (qualify-spec-symbol 'and)) 518 | (#{(qualify-core-symbol 'empty?)} c2) 519 | (#{(qualify-core-symbol 'coll?) 520 | (qualify-core-symbol 'map?)} 521 | c3))) 522 | (keyword (str "empty" 523 | (case (symbol (name (nth s 2))) 524 | coll? (or (let [[_ _ _ & args] s] 525 | (when (even? (count args)) 526 | (let [opts (apply hash-map args)] 527 | (when (#{(qualify-core-symbol 'vector?)} (:into opts)) 528 | "-vector")))) 529 | "-coll") 530 | map? "-map" 531 | nil)))) 532 | ;; give up, `uniquify` will handle clashes 533 | :spec)) 534 | specs) 535 | names (uniquify names) 536 | ;; FIXME sort by key, but preserve instance checks first 537 | names+specs (map vector names (map first specs))] 538 | (apply concat names+specs)))))))) 539 | 540 | ; Here we need to handle the pecularities of s/keys. 541 | ; 542 | ; Some interesting scenarios: 543 | ; 544 | ; 1. Simple HMap that needs to be converted to spec aliases 545 | ; Input: 546 | ; (t/defalias ABMap (t/HMap :optional {:a t/Int, :b t/Int})) 547 | ; Output: 548 | ; (s/def ::ABMap (s/keys :opt-un [::a ::b])) 549 | ; (s/def ::a int?) 550 | ; (s/def ::b int?) 551 | ; 552 | ; 2. Recursive HMap that needs to be converted to spec aliases 553 | ; Input: 554 | ; (t/defalias AMap (U nil (t/HMap :mandatory {:a AMap}))) 555 | ; Output: 556 | ; (s/def ::AMap (s/or :nil nil? :map (s/keys :req-un [::a]))) 557 | ; (s/def ::a ::AMap) 558 | ; 559 | ; 3. Nested HMap 560 | ; Input: 561 | ; (t/defalias AMap (t/HMap :mandatory {:a (t/HMap :mandatory {:b AMap})})) 562 | ; Output: 563 | ; (s/def ::AMap (s/keys :req-un [::a])) 564 | ; (s/def ::a (s/keys :req-un [::b])) 565 | ; (s/def ::b ::AMap) 566 | ; 567 | ; 4. Combine :req-un from different HMaps 568 | ; Input: 569 | ; (t/defalias AMap (t/HMap :mandatory {:a nil})) 570 | ; (t/defalias ABMap (t/HMap :mandatory {:a t/Int, :b nil})) 571 | ; Output: 572 | ; (s/def ::AMap (s/keys :req-un [::a])) 573 | ; (s/def ::ABMap (s/keys :req-un [::a ::b])) 574 | ; (s/def ::a (s/or :nil nil? :int int?)) 575 | ; (s/def ::b nil?) 576 | 577 | ; Plan: 578 | ; Add extra pass that recurs down type+alias envs and, for each HMap, add 579 | ; an appropriate alias to each entry. 580 | ; 581 | ; Continue doing this recursively until the type+alias environments do not change. 582 | ; 583 | ; Problem: 584 | ; For tagged maps we preserve key information, and it would be a problem 585 | ; if we moved or erased the tags. 586 | ; For these, add a :clojure.core.typed.annotator.frontend.spec/implicit-alias entry to the :val (or :union, sometimes) map 587 | ; that is the alias to use in spec generation. 588 | ; Then, need a special case in unparse-type to ensure :clojure.core.typed.annotator.frontend.spec/implicit-alias counts as 589 | ; as an alias usage. 590 | 591 | (defn accumulate-env [f env config ts] 592 | (loop [env env 593 | ts ts 594 | out []] 595 | (if (empty? ts) 596 | [env out] 597 | (let [[env t] (f env config (first ts))] 598 | (recur env 599 | (next ts) 600 | (conj out t)))))) 601 | 602 | (defn good-alias-name-for-key? [sym k] 603 | {:pre [(symbol? sym) 604 | (keyword? k)]} 605 | (if (namespace k) 606 | (= k (keyword sym)) 607 | (and (namespace sym) 608 | (= (name sym) (name k))))) 609 | 610 | (defn ensure-alias-for-spec-keys [env config [k t]] 611 | {:pre [(keyword? k)]} 612 | (let [a (or (when (r/alias? t) t) 613 | (:clojure.core.typed.annotator.frontend.spec/implicit-alias t))] 614 | (if (and (r/alias? a) 615 | (good-alias-name-for-key? (:name a) k)) 616 | [env t] 617 | (let [[sym env] (register-unique-alias-for-spec-keys env config k t) 618 | new-alias {:op :alias 619 | :name sym}] 620 | ;; maintain structure to calculate multi-spec's 621 | [env (if (kw-vals? t) 622 | (assoc t :clojure.core.typed.annotator.frontend.spec/implicit-alias new-alias) 623 | new-alias)])))) 624 | 625 | (defn implicit-aliases-for-type [env config m] 626 | (let [maybe-recur-entry (fn [env m kw] 627 | (if-let [v (get m kw)] 628 | (let [[env v] (implicit-aliases-for-type env config v)] 629 | [env (assoc m kw v)]) 630 | [env m])) 631 | recur-vec-entry (fn [env m kw] 632 | (let [[env ts] (accumulate-env implicit-aliases-for-type env config (get m kw))] 633 | [env (assoc m kw ts)]))] 634 | (case (:op m) 635 | (:free :unknown :alias :val :Top) [env m] 636 | :union (recur-vec-entry env m :types) 637 | :HVec (recur-vec-entry env m :vec) 638 | :HMap (let [process-HMap-entries (fn [env es] 639 | {:pre [(map? es)]} 640 | (let [[env ts] (accumulate-env implicit-aliases-for-type env config (vals es)) 641 | es (zipmap (keys es) ts) 642 | [env ts] (accumulate-env ensure-alias-for-spec-keys env config es) 643 | es (zipmap (keys es) ts)] 644 | [env es])) 645 | [env req] (process-HMap-entries env (:clojure.core.typed.annotator.rep/HMap-req m)) 646 | [env opt] (process-HMap-entries env (:clojure.core.typed.annotator.rep/HMap-opt m))] 647 | [env (assoc m 648 | :clojure.core.typed.annotator.rep/HMap-req req 649 | :clojure.core.typed.annotator.rep/HMap-opt opt)]) 650 | (:class :unresolved-class) (recur-vec-entry env m :args) 651 | :IFn (recur-vec-entry env m :arities) 652 | :IFn1 (let [[env m] (recur-vec-entry env m :dom) 653 | [env m] (maybe-recur-entry env m :rng) 654 | [env m] (maybe-recur-entry env m :rest)] 655 | [env m]) 656 | #_:poly ;TODO 657 | (assert nil (str "No implicit-aliases-for-type case: " m))))) 658 | 659 | (defn implicit-aliases-for-tenv [env config] 660 | (loop [tenv (type-env env) 661 | out {} 662 | env env] 663 | (if (empty? tenv) 664 | (update-type-env env (constantly out)) 665 | (let [[k t] (first tenv) 666 | [env t] (implicit-aliases-for-type env config t)] 667 | (recur (next tenv) 668 | (assoc out k t) 669 | env))))) 670 | 671 | ; If aliases are recursive, we have to be careful we don't clobber any changes 672 | ; made to them. For example, when we traverse qual/a, we'll need to register 673 | ; `nil` as part of qual/a's type. Simply adding implicit aliases to '{:qual/a nil} 674 | ; is not enough. 675 | ; 676 | ; Input: 677 | ; (defalias qual/a '{:qual/a nil}) 678 | ;=> 679 | ; Output: 680 | ; (defalias qual/a (U nil '{:qual/a qual/a})) 681 | ; 682 | ; We can't just `join` the updated alias, since it will not have implicit aliases 683 | ; eg. above, we'll get `(defalias qual/a (U nil '{:qual/a nil}))` 684 | ; So, iterate on generating qual/a until it is stable. 685 | ; 686 | ; Input: 687 | ; (defalias qual/a '{:qual/a nil}) 688 | ;=> 689 | ; (defalias qual/a (U nil '{:qual/a nil})) 690 | ;=> 691 | ; (defalias qual/a (U nil '{:qual/a nil})) 692 | ; Output: 693 | ; (defalias qual/a (U nil '{:qual/a qual/a})) 694 | ; 695 | 696 | ;; should only need max 2 iterations I think? 697 | (def fixed-point-limit 3) 698 | 699 | (defn implicit-aliases-for-aenv [env config] 700 | (loop [as (keys (alias-env env)) 701 | env env] 702 | (if (empty? as) 703 | env 704 | (let [implicit-alias-fixed-point 705 | (fn [env k] 706 | (loop [old-alias (get (alias-env env) k) 707 | env env 708 | cnt 0] 709 | (assert old-alias) 710 | (assert (< cnt fixed-point-limit)) 711 | (let [[env t] (implicit-aliases-for-type env config old-alias) 712 | changed-alias (get (alias-env env) k)] 713 | ;; if the current alias hasn't change from traversing it, 714 | ;; we can be sure that we've correctly calculated the implicit aliases 715 | ;; of this alias. 716 | (if (= old-alias changed-alias) 717 | (update-alias-env env assoc k t) 718 | (recur changed-alias 719 | env 720 | (inc cnt))))))] 721 | (recur (next as) 722 | (implicit-alias-fixed-point env (first as))))))) 723 | 724 | (defn implicit-aliases-for-env [env config] 725 | (let [env (implicit-aliases-for-tenv env config) 726 | env (implicit-aliases-for-aenv env config)] 727 | env)) 728 | 729 | (defn unparse-spec-aliases [env used-aliases] 730 | (loop [worklist (vec used-aliases) 731 | done-sdefs {}] 732 | (if (empty? worklist) 733 | done-sdefs 734 | (let [a (nth worklist 0)] 735 | (if (done-sdefs a) 736 | (recur (subvec worklist 1) 737 | done-sdefs) 738 | (let [add-to-worklist (atom #{}) 739 | e (binding [*used-aliases* add-to-worklist] 740 | (unparse-spec (get (alias-env env) a)))] 741 | (recur (into (subvec worklist 1) 742 | (remove done-sdefs) 743 | @add-to-worklist) 744 | (assoc done-sdefs a e)))))))) 745 | 746 | 747 | (defn envs-to-specs [env {:keys [spec-macros allow-top-level-non-IFn] :as config}] 748 | ;(prn "envs-to-specs" (keys (alias-env env))) 749 | (let [should-spec-macros? (boolean spec-macros) 750 | trim-type-env #?(:clj 751 | #(into {} 752 | (remove (fn [[k v]] 753 | (or ;; don't spec local functions 754 | (local-fn-symbol? k) 755 | ;; macro specs are opt-in 756 | (if should-spec-macros? 757 | false 758 | (macro-symbol? k)) 759 | ;; don't spec external functions 760 | (imported-symbol? k) 761 | ;; only output fdef's. spec seems to assume all 762 | ;; top level def's are functions, which breaks spec instrumentation. 763 | ;; We work around this behaviour by simply 764 | ;; omitting non-function specs. 765 | (if allow-top-level-non-IFn 766 | false 767 | (not (#{:IFn} (:op v))))))) 768 | %) 769 | :cljs identity) 770 | ;_ (prn "pre env" env) 771 | env (update-type-env env trim-type-env) 772 | ;_ (prn "allow-top-level-non-IFn" allow-top-level-non-IFn) 773 | ;_ (prn "env" env) 774 | env (implicit-aliases-for-env env config) 775 | aliases-generated (atom #{})] 776 | (binding [*envs* (atom env)] 777 | (let [used-aliases (atom #{}) 778 | multispecs-needed (atom {}) 779 | unparse-spec' (fn [s] 780 | (binding [*used-aliases* used-aliases 781 | *multispecs-needed* multispecs-needed] 782 | (unparse-spec s))) 783 | top-level-types 784 | (into [] 785 | (mapcat (fn [[k v]] 786 | (let [s (unparse-spec' (assoc v :top-level-def k)) 787 | sym (if (= (namespace k) 788 | (str (ns-name (current-ns)))) 789 | ;; defs 790 | (symbol (name k)) 791 | ;; imports 792 | k) 793 | ;old-spec (get-spec-form k) 794 | spec-to-maybe-fdef 795 | (fn [sym s] 796 | (if (and (seq? s) 797 | (#{(qualify-spec-symbol 'fspec)} 798 | (first s))) 799 | (list*-force (qualify-spec-symbol 'fdef) 800 | sym 801 | (next s)) 802 | (def-spec sym s))) 803 | sdef (spec-to-maybe-fdef sym s)] 804 | [sdef]))) 805 | (sort-by first (type-env env))) 806 | 807 | ;_ (prn "used-aliases" @used-aliases) 808 | ; depends on side effects from above call 809 | aenv (binding [*multispecs-needed* multispecs-needed] 810 | (unparse-spec-aliases env (sort @used-aliases))) 811 | _ (every? (fn [[_ specs]] 812 | (assert (#{1} (count specs)) 813 | (str "Clash in alias generation: " specs))) 814 | (group-by alias->spec-kw (keys aenv))) 815 | unparsed-aliases (mapv (fn [[sym spc]] (def-spec (alias->spec-kw sym) spc)) 816 | (sort-by first aenv)) 817 | ; depends on side effects from both above calls 818 | multispecs (apply concat (map second (sort-by first @multispecs-needed))) 819 | ;; multispecs first, since aliases refer to them 820 | top-level-types (vec (concat multispecs 821 | unparsed-aliases 822 | top-level-types))] 823 | {:top-level top-level-types 824 | :requires (when-let [requires (:explicit-require-needed config)] 825 | [requires])})))) 826 | --------------------------------------------------------------------------------