4 |
5 | Runtime dependency needed to annotate Typed Clojure code in 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.1.
17 |
18 | * [All Released Versions](https://search.maven.org/search?q=g:org.clojure%20AND%20a:core.typed.runtime.jvm)
19 |
20 | [deps.edn](https://clojure.org/reference/deps_and_cli) dependency information:
21 |
22 | ```clj
23 | org.clojure/core.typed.runtime.jvm {:mvn/version "0.7.1"}
24 | ```
25 |
26 | [Leiningen](https://github.com/technomancy/leiningen) dependency information:
27 |
28 | ```clojure
29 | [org.clojure/core.typed.runtime.jvm "0.7.1"]
30 | ```
31 |
32 | [Maven](https://maven.apache.org/) dependency information:
33 |
34 | ```XML
35 | 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/rules.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.rules 10 | (:require [clojure.core.typed :as t] 11 | [clojure.core.typed.internal :as internal] 12 | [clojure.core.typed.analyzer :as ana2])) 13 | 14 | (t/defalias TCType t/Any) 15 | (t/defalias MsgFnOpts (t/HMap)) 16 | 17 | (t/defalias AST (t/Map t/Any t/Any)) 18 | 19 | (t/defalias ExprType 20 | (t/HMap :mandatory 21 | {;; the type 22 | :type TCType} 23 | ;; filter set 24 | :optional 25 | {:filters (t/HMap :optional 26 | {:then t/Any 27 | :else t/Any}) 28 | ;; the object 29 | :object t/Any 30 | ;; the flow filter 31 | :flow t/Any 32 | :opts (t/HMap :optional 33 | {:msg-fn [MsgFnOpts -> t/Str] 34 | :blame-form t/Any})})) 35 | 36 | (t/defalias ErrorOpts (t/HMap 37 | :optional 38 | {:expected (t/U nil ExprType)})) 39 | 40 | (t/defalias RuleOpts 41 | (t/HMap :mandatory 42 | {; FIXME docs 43 | :expr AST 44 | ; FIXME docs 45 | :opts t/Any 46 | ;; the fully qualified symbol of the current 47 | ;; macro being type checked 48 | :vsym t/Sym 49 | ;; Map of current tools.analyzer local scope 50 | :locals (t/Map t/Sym t/Any) 51 | ;; expected type of the current form 52 | :expected (t/U nil ExprType) 53 | ;; (fn [actual maybe-expected] ..) 54 | ;; if provided, checks actual is compatible with the expected type 55 | :maybe-check-expected [ExprType (t/U nil ExprType) -> ExprType] 56 | ;; (fn ([form] ..) ([form expected-type] ..)) 57 | ;; type checks form with an optional expected-type 58 | :check (t/IFn [t/Any -> ExprType] 59 | [t/Any (t/U nil ExprType) -> ExprType]) 60 | ;; (fn [vs f] ..) 61 | ;; FIXME docs 62 | ;:solve-subtype [(t/Vec t/Sym) [t/Sym * :-> [TCType TCType]] :-> (t/U nil (t/Map t/Sym TCType))] 63 | ;; (fn [t1 t2] ..) 64 | ;; true if t1 is a subtype of t2 65 | :subtype? [TCType TCType :-> Boolean] 66 | ;; given a tools.analyzer AST form, returns its Clojure representation 67 | :emit-form [t/Any :-> t/Any] 68 | ;; compacts a type so it is suitable to use in an error message 69 | :abbreviate-type [TCType :-> TCType] 70 | ;;TODO document 71 | :expected-error [TCType ExprType ErrorOpts :-> t/Any] 72 | :delayed-error [t/Str ErrorOpts :-> t/Any] 73 | :internal-error [t/Str ErrorOpts :-> t/Any] 74 | })) 75 | 76 | (t/ann typing-rule [RuleOpts -> '{:op t/Kw, ::expr-type ExprType}]) 77 | (defmulti typing-rule (fn [{:keys [vsym]}] vsym)) 78 | 79 | (defmulti macro-rule (fn [_ _ {:keys [vsym]}] vsym)) 80 | 81 | ;copied from clojure.core 82 | (defn- get-super-and-interfaces [bases] 83 | (if (. ^Class (first bases) (isInterface)) 84 | [Object bases] 85 | [(first bases) (next bases)])) 86 | 87 | (defmethod macro-rule 'clojure.core/proxy 88 | [[_ class-and-interfaces args & fs :as form] expected _] 89 | (let [bases (map #(or (resolve %) (throw (Exception. (str "Can't resolve: " %)))) 90 | class-and-interfaces) 91 | [super interfaces] (get-super-and-interfaces bases) 92 | ^Class pc-effect (apply get-proxy-class bases) 93 | pname (proxy-name super interfaces) 94 | super (.getSuperclass pc-effect) 95 | t `(t/I ~@(map (comp symbol #(.getName ^Class %)) bases))] 96 | {:form `(^::t/untyped proxy [] ~args ~@fs) 97 | ::expr-type {:type t}})) 98 | 99 | #_ 100 | (defmethod typing-rule 'clojure.core.typed.expand/gather-for-return-type 101 | [{[_ ret] :form, :keys [expected check solve]}] 102 | (assert nil "FIXME args etc.") 103 | (let [{:keys [::expr-type] :as m} (check ret) 104 | {:keys [x] :as solved?} (solve-subtype '[x] 105 | (fn [x] 106 | [(:type expr-type) `(t/U nil '[~x])])) 107 | _ (assert solved?) 108 | ret {:type `(t/Seq ~x) 109 | :filters {:else 'ff}}] 110 | (assoc m ::expr-type ret))) 111 | 112 | (defmethod typing-rule 'clojure.core.typed.expand/expected-type-as 113 | [{:keys [expr opts expected check delayed-error form with-updated-locals]}] 114 | (let [{:keys [sym msg-fn blame-form]} opts] 115 | (if expected 116 | (with-updated-locals {sym (:type expected)} 117 | #(check expr expected)) 118 | (do 119 | (delayed-error (if msg-fn 120 | ((eval msg-fn) {}) 121 | "Must provide expected to this expression") 122 | {:form (if (contains? opts :blame-form) 123 | blame-form 124 | form)}) 125 | (assoc expr ::expr-type {:type `t/TCError}))))) 126 | 127 | ;; (solve 128 | ;; coll 129 | ;; {:query (t/All [a] [(t/U nil (t/Seqable a)) :-> a]) 130 | ;; :msg-fn (fn [_#] 131 | ;; (str "Argument number " ~(inc i) 132 | ;; " to 'map' must be Seqable")) 133 | ;; :blame-form ~coll}) 134 | (defmethod typing-rule 'clojure.core.typed.expand/solve 135 | [{:keys [expr opts expected check solve delayed-error form maybe-check-expected]}] 136 | (let [{:keys [query msg-fn blame-form]} opts 137 | {::keys [expr-type] :as cexpr} (check expr) 138 | res (solve expr-type query)] 139 | (when-not res 140 | (let [form (if (contains? opts :blame-form) 141 | blame-form 142 | form)] 143 | ;; msg-fn should provide message 144 | (delayed-error nil (merge {:form form :actual (:type expr-type)} 145 | (select-keys opts [:msg-fn :blame-form]))))) 146 | (assoc cexpr 147 | ::expr-type (maybe-check-expected 148 | (or res {:type `t/TCError}) 149 | expected)))) 150 | 151 | (defmethod typing-rule 'clojure.core.typed.expand/require-expected 152 | [{:keys [expr opts expected check solve delayed-error form maybe-check-expected subtype?]}] 153 | (let [sub-check (:subtype opts) 154 | msg-fn (:msg-fn opts)] 155 | (cond 156 | (or (not expected) 157 | (and expected 158 | (contains? opts :subtype) 159 | (not (subtype? (:type expected) sub-check)))) 160 | (let [form (if-let [[_ bf] (find opts :blame-form)] 161 | bf 162 | form) 163 | msg (if msg-fn 164 | ((eval msg-fn) {}) 165 | (str "An expected type " 166 | (when (contains? opts :subtype) 167 | (str "which is a subtype of " (pr-str sub-check))) 168 | " is required for this expression."))] 169 | (delayed-error msg {:form form}) 170 | (assoc expr ::expr-type {:type `t/TCError})) 171 | 172 | :else (check expr expected)))) 173 | 174 | #_ 175 | (defmethod typing-rule 'clojure.core.typed.expand/check-for-expected 176 | [{[_ {:keys [expr expected-local] :as form-opts} :as form] :form, 177 | :keys [expr opts expected check locals solve-subtype subtype? delayed-error abbreviate-type 178 | emit-form] :as opt}] 179 | (assert nil "FIXME update args above and defmacro") 180 | (assert (not (:expected opt))) 181 | (let [{:keys [expected-local]} opts 182 | l (get locals expected-local) 183 | _ (assert l expected-local) 184 | [qut expected] (-> l :init emit-form) 185 | _ (assert (= 'quote qut)) 186 | {:syms [x] :as solved?} (when expected 187 | (solve-subtype '[x] 188 | (fn [x] 189 | [(:type expected) `(t/U nil (t/Seqable ~x))]))) 190 | ;; TODO check-below of filters/object/flow 191 | errored? (when expected 192 | (when-not (subtype? `(t/Seq t/Nothing) (:type expected)) 193 | (delayed-error (str "'for' expression returns a seq, but surrounding context expected it to return " 194 | (pr-str (abbreviate-type (:type expected)))) 195 | {:form (:form form-opts)}) 196 | true)) 197 | _ (assert (or solved? errored? (not expected)))] 198 | (check expr (when expected 199 | (when solved? 200 | (when (not errored?) 201 | {:type x})))))) 202 | 203 | (defn update-expected-with-check-expected-opts 204 | [expected opts] 205 | (assert (map? opts) (pr-str (class opts))) 206 | (when-let [expected (or expected 207 | (:default-expected opts) 208 | #_ 209 | {:type `^::t/infer t/Any 210 | :filters {:then 'no-filter 211 | :else 'no-filter} 212 | :flow 'no-filter 213 | :object 'no-object})] 214 | (update expected :opts 215 | ;; earlier messages override later ones 216 | #(merge 217 | (select-keys opts [:blame-form :msg-fn]) 218 | %)))) 219 | 220 | (defmethod typing-rule 'clojure.core.typed.expand/check-expected 221 | [{:keys [expr opts expected check]}] 222 | (check expr (update-expected-with-check-expected-opts expected opts))) 223 | 224 | (defmethod typing-rule 'clojure.core.typed.expand/check-if-empty-body 225 | [{:keys [expr opts expected check]}] 226 | (check expr (when expected 227 | (if (empty? (:original-body opts)) 228 | (update expected :opts 229 | ;; earlier messages override later ones 230 | #(merge 231 | (select-keys opts [:blame-form :msg-fn]) 232 | %)) 233 | expected)))) 234 | 235 | ;TODO use ana2/run-passes & ana2/unmark-eval-top-level 236 | (defmethod typing-rule 'clojure.core.typed.expand/type-error 237 | [{:keys [expr opts delayed-error]}] 238 | (let [{:keys [msg-fn form]} opts] 239 | (delayed-error ((eval msg-fn) {}) {:form form}) 240 | (assoc expr ::expr-type {:type `t/TCError}))) 241 | 242 | (defmethod typing-rule 'clojure.core.typed.expand/with-post-blame-context 243 | [{:keys [expr opts env expected check]} ] 244 | (let [ce (check expr expected)] 245 | (update-in ce [::expr-type :opts] 246 | ;; earlier messages override later ones 247 | #(merge 248 | (select-keys opts [:blame-form :msg-fn]) 249 | %)))) 250 | 251 | ;; FIXME use check-below!! 252 | (defn ann-form-typing-rule 253 | [{:keys [expr opts expected check subtype? expected-error]}] 254 | {:pre [(map? opts)]} 255 | #_ 256 | (prn "ann-form-typing-rule" opts expected (class expected)) 257 | (let [_ (assert (contains? opts :type)) 258 | {ty :type, :keys [inner-check-expected outer-check-expected]} opts 259 | _ (assert (map? inner-check-expected) inner-check-expected) 260 | _ (assert (map? outer-check-expected) outer-check-expected) 261 | _ (when expected 262 | ;; FIXME use check-below!! 263 | (when-not (subtype? ty (:type expected)) 264 | (expected-error ty expected 265 | {:expected (update-expected-with-check-expected-opts 266 | expected outer-check-expected)})))] 267 | (check expr (update-expected-with-check-expected-opts 268 | (merge expected {:type ty}) inner-check-expected)))) 269 | 270 | (defmethod typing-rule `t/ann-form [& args] (apply ann-form-typing-rule args)) 271 | (defmethod typing-rule 'clojure.core.typed.macros/ann-form [& args] (apply ann-form-typing-rule args)) 272 | 273 | (defn tc-ignore-typing-rule 274 | [{:keys [expr opts expected maybe-check-expected]}] 275 | {:pre [(map? opts)]} 276 | #_ 277 | (prn "tc-ignore-typing-rule" opts) 278 | (let [expr (-> expr 279 | ana2/run-passes 280 | ; ensure the main checking loop doesn't reevaluate this tc-ignore, 281 | ; since run-passes has already if this is top-level. 282 | ana2/unmark-eval-top-level)] 283 | 284 | (assoc expr 285 | ::expr-type (maybe-check-expected 286 | {:type `t/Any} 287 | (update-expected-with-check-expected-opts 288 | expected (:outer-check-expected opts)))))) 289 | 290 | (defmethod typing-rule `t/tc-ignore [& args] (apply tc-ignore-typing-rule args)) 291 | (defmethod typing-rule 'clojure.core.typed.macros/tc-ignore [& args] (apply tc-ignore-typing-rule args)) 292 | 293 | (defmethod typing-rule 'clojure.core.typed.expand/ignore-expected-if 294 | [{[_ ignore? body :as form] :form, :keys [expected check]}] 295 | {:pre [(boolean? ignore?)]} 296 | (assert nil "FIXME args etc.") 297 | (check body (when-not ignore? expected))) 298 | 299 | (defmethod typing-rule :default 300 | [{:keys [form internal-error]}] 301 | (internal-error (str "No such internal form: " form))) 302 | -------------------------------------------------------------------------------- /src/main/clojure/cljs/core/typed.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 ^:no-doc cljs.core.typed 10 | "Macros for Clojurescript type checking" 11 | (:refer-clojure :exclude [fn loop let defn atom defprotocol]) 12 | (:require [clojure.core.typed.load-if-needed :as load] 13 | [clojure.core :as core] 14 | [clojure.core.typed.current-impl :as impl] 15 | [clojure.core.typed.util-vars :as vs] 16 | [clojure.core.typed.internal :as internal] 17 | [clojure.core.typed.errors :as err] 18 | [clojure.core.typed.special-form :as spec] 19 | [clojure.core.typed.import-macros :as import-m] 20 | [clojure.core.typed.macros :as macros] 21 | [clojure.pprint :as pprint])) 22 | 23 | (import-m/import-macros clojure.core.typed.macros 24 | [fn tc-ignore ann-form def loop let defn atom defprotocol]) 25 | 26 | (defn load-if-needed 27 | "Load and initialize all of core.typed if not already" 28 | [] 29 | (load/load-if-needed true)) 30 | 31 | (let [rc (delay (impl/dynaload 'clojure.core.typed.checker.jvm.reset-caches/reset-caches))] 32 | (defn reset-caches 33 | "Reset internal type caches." 34 | [] 35 | (load-if-needed) 36 | (@rc))) 37 | 38 | ; many of these macros resolve to CLJS functions in 39 | ; the CLJS ns cljs.core.typed 40 | 41 | (def ^:private parse-cljs (delay (impl/dynaload 'clojure.core.typed.checker.jvm.parse-unparse/parse-cljs))) 42 | (def ^:private cljs-ns (delay (impl/dynaload 'clojure.core.typed.util-cljs/cljs-ns))) 43 | (def ^:private with-parse-ns* (delay (impl/dynaload 'clojure.core.typed.checker.jvm.parse-unparse/with-parse-ns*))) 44 | 45 | (defmacro ^:private delay-tc-parse 46 | [t] 47 | `(let [t# ~t 48 | app-outer-context# (bound-fn [f#] (f#))] 49 | (delay 50 | (app-outer-context# 51 | (fn [] 52 | (@with-parse-ns* 53 | (@cljs-ns) 54 | #(@parse-cljs t#))))))) 55 | 56 | (defmacro ^:skip-wiki with-current-location 57 | [{:keys [form env]} & body] 58 | `(let [form# ~form 59 | env# ~env] 60 | (binding [vs/*current-env* {:ns (or (:ns env#) 61 | {:name (@cljs-ns)}) 62 | :line (or (-> form# meta :line) 63 | (:line env#) 64 | :column (or (-> form# meta :column) 65 | (:column env#)))}] 66 | ~@body))) 67 | 68 | (defn ^:skip-wiki 69 | ann*-macro-time 70 | "Internal use only. Use ann." 71 | [qsym typesyn check? form env] 72 | (let [_ (impl/with-impl impl/clojurescript 73 | (when (and (contains? (impl/var-env) qsym) 74 | (not (impl/check-var? qsym)) 75 | check?) 76 | (err/warn (str "Removing :no-check from var " qsym)) 77 | (impl/remove-nocheck-var qsym))) 78 | _ (impl/with-impl impl/clojurescript 79 | (when-not check? 80 | (impl/add-nocheck-var qsym))) 81 | #_#_ast (with-current-location {:form form :env env} 82 | (delay-rt-parse typesyn)) 83 | tc-type (with-current-location {:form form :env env} 84 | (delay-tc-parse typesyn))] 85 | #_(impl/with-impl impl/clojurescript 86 | (impl/add-var-env qsym ast)) 87 | (impl/with-impl impl/clojurescript 88 | (impl/add-tc-var-type qsym tc-type))) 89 | nil) 90 | 91 | (let [cljs-resolve (delay (impl/dynaload 'cljs.analyzer.api/resolve))] 92 | (defmacro ann 93 | "Annotate varsym with type. If unqualified, qualify in the current namespace. 94 | If varsym has metadata {:no-check true}, ignore definitions of varsym while type checking. 95 | 96 | eg. ; annotate the var foo in this namespace 97 | (ann foo [Number -> Number]) 98 | 99 | ; annotate a var in another namespace 100 | (ann another.ns/bar [-> nil]) 101 | 102 | ; don't check this var 103 | (ann ^:no-check foobar [Integer -> String])" 104 | [varsym typesyn] 105 | (let [{:keys [name]} (@cljs-resolve &env varsym) 106 | qsym name 107 | opts (meta varsym) 108 | check? (not (:no-check opts))] 109 | (ann*-macro-time qsym typesyn check? &form &env) 110 | `(tc-ignore (ann* '~qsym '~typesyn '~check? '~&form))))) 111 | 112 | (defmacro 113 | ^{:forms '[(ann-protocol vbnd varsym & methods) 114 | (ann-protocol varsym & methods)]} 115 | ann-protocol 116 | "Annotate a possibly polymorphic protocol var with method types. 117 | 118 | eg. (ann-protocol IFoo 119 | bar 120 | [IFoo -> Any] 121 | baz 122 | [IFoo -> Number]) 123 | 124 | ; polymorphic 125 | (ann-protocol [[x :variance :covariant]] 126 | IFoo 127 | bar 128 | [IFoo -> Any] 129 | baz 130 | [IFoo -> Number])" 131 | [& args] 132 | (let [bnd-provided? (vector? (first args)) 133 | vbnd (when bnd-provided? 134 | (first args)) 135 | varsym (if bnd-provided? 136 | (second args) 137 | (first args)) 138 | {:as mth} (if bnd-provided? 139 | (next (next args)) 140 | (next args))] 141 | `(ann-protocol* '~vbnd '~varsym '~mth))) 142 | 143 | (defmacro ann-jsnominal 144 | "Equivalent of TypeScript interface" 145 | [varsym jsnom] 146 | (let [qualsym (if (namespace varsym) 147 | varsym 148 | (symbol (str (ns-name *ns*)) (name varsym)))] 149 | `(ann-jsnominal* '~qualsym '~jsnom))) 150 | 151 | (defmacro 152 | ^{:forms '[(ann-datatype dname [field :- type*] opts*) 153 | (ann-datatype binder dname [field :- type*] opts*)]} 154 | ann-datatype 155 | "Annotate datatype Class name dname with expected fields. 156 | If unqualified, qualify in the current namespace. 157 | 158 | eg. (ann-datatype MyDatatype [a :- Number, 159 | b :- Long]) 160 | 161 | (ann-datatype another.ns.TheirDatatype 162 | [str :- String, 163 | vec :- (IPersistentVector Number)])" 164 | [& args] 165 | ;[dname fields & {ancests :unchecked-ancestors rplc :replace :as opts}] 166 | (let [bnd-provided? (vector? (first args)) 167 | vbnd (when bnd-provided? 168 | (first args)) 169 | [dname fields & {ancests :unchecked-ancestors rplc :replace :as opts}] 170 | (if bnd-provided? 171 | (next args) 172 | args)] 173 | (assert (not rplc) "Replace NYI") 174 | (assert (symbol? dname) 175 | (str "Must provide name symbol: " dname)) 176 | `(ann-datatype* '~vbnd '~dname '~fields '~opts))) 177 | 178 | (defmacro defalias 179 | "Define a type alias. Takes an optional doc-string as a second 180 | argument. 181 | 182 | Updates the corresponding var with documentation. 183 | 184 | eg. (defalias MyAlias 185 | \"Here is my alias\" 186 | (U nil String))" 187 | ([sym doc-str t] 188 | (assert (string? doc-str) "Doc-string passed to defalias must be a string") 189 | `(defalias ~sym ~t)) 190 | ([sym t] 191 | (assert (symbol? sym) (str "First argument to defalias must be a symbol: " sym)) 192 | `(do (def-alias* '~sym '~t) 193 | ~(when-not (namespace sym) 194 | `(def ~sym))))) 195 | 196 | (defmacro inst 197 | "Instantiate a polymorphic type with a number of types" 198 | [inst-of & types] 199 | `(inst-poly ~inst-of '~types)) 200 | 201 | (defmacro 202 | ^{:forms '[(letfn> [fn-spec-or-annotation*] expr*)]} 203 | letfn> 204 | "Like letfn, but each function spec must be annotated. 205 | 206 | eg. (letfn> [a :- [Number -> Number] 207 | (a [b] 2) 208 | 209 | c :- [Symbol -> nil] 210 | (c [s] nil)] 211 | ...)" 212 | [fn-specs-and-annotations & body] 213 | (let [bindings fn-specs-and-annotations 214 | ; (Vector (U '[Symbol TypeSyn] LetFnInit)) 215 | normalised-bindings 216 | (core/loop [[fbnd :as bindings] bindings 217 | norm []] 218 | (cond 219 | (empty? bindings) norm 220 | (symbol? fbnd) (do 221 | (assert (#{:-} (second bindings)) 222 | "letfn> annotations require :- separator") 223 | (assert (<= 3 (count bindings))) 224 | (recur 225 | (drop 3 bindings) 226 | (conj norm [(nth bindings 0) 227 | (nth bindings 2)]))) 228 | (list? fbnd) (recur 229 | (next bindings) 230 | (conj norm fbnd)) 231 | :else (throw (Exception. (str "Unknown syntax to letfn>: " fbnd))))) 232 | {anns false inits true} (group-by list? normalised-bindings) 233 | ; init-syn unquotes local binding references to be compatible with hygienic expansion 234 | init-syn (into {} 235 | (for [[lb type] anns] 236 | [lb `'~type]))] 237 | `(cljs.core/letfn ~(vec inits) 238 | ;unquoted to allow bindings to resolve with hygiene 239 | ~init-syn 240 | ;;preserve letfn empty body 241 | ;;nil 242 | ~@body))) 243 | 244 | (defmacro 245 | ^{:forms '[(loop> [binding :- type, init*] exprs*)]} 246 | ^{:deprecated "0.2.61"} 247 | loop> 248 | "DEPRECATED: use loop 249 | 250 | Like loop, except loop variables require annotation. 251 | 252 | Suggested idiom: use a comma between the type and the initial 253 | expression. 254 | 255 | eg. (loop> [a :- Number, 1 256 | b :- (U nil Number), nil] 257 | ...)" 258 | [bndings* & forms] 259 | (let [normalise-args 260 | (core/fn [seq-exprs] 261 | (core/loop [flat-result () 262 | seq-exprs seq-exprs] 263 | (cond 264 | (empty? seq-exprs) flat-result 265 | (and (vector? (first seq-exprs)) 266 | (#{:-} (-> seq-exprs first second))) (do 267 | (prn "DEPRECATED WARNING: loop> syntax has changed, use [b :- t i] for clauses" 268 | "ns: " *ns* " form:" &form) 269 | (recur (concat flat-result (take 2 seq-exprs)) 270 | (drop 2 seq-exprs))) 271 | :else (do (assert (#{:-} (second seq-exprs)) 272 | "Incorrect syntax in loop>.") 273 | (recur (concat flat-result [(vec (take 3 seq-exprs)) 274 | (nth seq-exprs 3)]) 275 | (drop 4 seq-exprs)))))) 276 | ;group args in flat pairs 277 | bndings* (normalise-args bndings*) 278 | bnds (partition 2 bndings*) 279 | ; [[lhs :- bnd-ann] rhs] 280 | lhs (map ffirst bnds) 281 | rhs (map second bnds) 282 | bnd-anns (map #(-> % first next second) bnds)] 283 | `(loop>-ann (cljs.core/loop ~(vec (mapcat vector lhs rhs)) 284 | ~@forms) 285 | '~bnd-anns))) 286 | 287 | (defmacro typed-deps 288 | "Declare namespaces which should be checked before the current namespace. 289 | Accepts any number of symbols. 290 | 291 | eg. (typed-deps clojure.core.typed.holes 292 | myns.types)" 293 | [& args] 294 | `(typed-deps* '~args)) 295 | 296 | (let [check-form-cljs (delay (impl/dynaload 'clojure.core.typed.checker.js.check-form-cljs/check-form-cljs))] 297 | (defn cf* 298 | "Check a single form with an optional expected type. 299 | Intended to be called from Clojure. For evaluation at the Clojurescript 300 | REPL see cf." 301 | [form expected expected-provided?] 302 | (load-if-needed) 303 | (@check-form-cljs form expected expected-provided?))) 304 | 305 | (let [chkfi (delay (impl/dynaload 'clojure.core.typed.checker.js.check-form-cljs/check-form-info))] 306 | (defn check-form-info 307 | [form & opts] 308 | (load-if-needed) 309 | (apply @chkfi form opts))) 310 | 311 | (defmacro cf 312 | "Check a single form with an optional expected type." 313 | ([form] `(cf* '~form nil nil)) 314 | ([form expected] `(cf* '~form '~expected true))) 315 | 316 | (let [chkni (delay (impl/dynaload 'clojure.core.typed.checker.js.check-ns-cljs/check-ns-info))] 317 | (defn check-ns-info 318 | "Check a Clojurescript namespace, or the current namespace. 319 | Intended to be called from Clojure. For evaluation at the Clojurescript 320 | REPL see check-ns." 321 | ([] 322 | (load-if-needed) 323 | (check-ns-info (@cljs-ns))) 324 | ([ns-or-syms & {:as opt}] 325 | (load-if-needed) 326 | (@chkni ns-or-syms opt)))) 327 | 328 | (let [chkns (delay (impl/dynaload 'clojure.core.typed.checker.js.check-ns-cljs/check-ns))] 329 | (defn check-ns* 330 | "Check a Clojurescript namespace, or the current namespace. 331 | Intended to be called from Clojure. For evaluation at the Clojurescript 332 | REPL see check-ns." 333 | ([] 334 | (load-if-needed) 335 | (check-ns* (@cljs-ns))) 336 | ([ns-or-syms & {:as opt}] 337 | (load-if-needed) 338 | (@chkns ns-or-syms opt)))) 339 | 340 | (defmacro check-ns 341 | "Check a Clojurescript namespace, or the current namespace. This macro 342 | is intended to be called at the Clojurescript REPL. For the equivalent function see 343 | check-ns*. 344 | 345 | The symbols *ns* and clojure.core/*ns* are special and refer to the current namespace. Useful if 346 | providing options for the current namespace." 347 | ([] 348 | (load-if-needed) 349 | `(check-ns *ns*)) 350 | ([ns-or-syms & args] 351 | (load-if-needed) 352 | (let [_ (when (and (list? ns-or-syms) 353 | (#{'quote} (first ns-or-syms))) 354 | (err/int-error "check-ns is a macro, do not quote the first argument")) 355 | ns-or-syms (if ('#{*ns* clojure.core/*ns*} ns-or-syms) 356 | (@cljs-ns) 357 | ns-or-syms)] 358 | `~(apply check-ns* ns-or-syms args)))) 359 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/async.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 10 | ^{:doc 11 | "This namespace contains annotations and helper macros for type 12 | checking core.async code. Ensure clojure.core.async is require'd 13 | before performing type checking. 14 | 15 | go 16 | use go 17 | 18 | chan 19 | use chan 20 | 21 | buffer 22 | use buffer (similar for other buffer constructors) 23 | "} 24 | clojure.core.typed.async 25 | (:require [clojure.core.typed :refer [ann ann-datatype defalias inst ann-protocol] 26 | :as t] 27 | [clojure.core.async :as async] 28 | [clojure.core.async.impl.protocols :as impl] 29 | [clojure.core.async.impl.channels :as channels] 30 | [clojure.core.async.impl.dispatch :as dispatch] 31 | [clojure.core.async.impl.ioc-macros :as ioc] 32 | ) 33 | (:import (java.util.concurrent Executor) 34 | (java.util.concurrent.locks Lock) 35 | (java.util.concurrent.atomic AtomicReferenceArray) 36 | (clojure.lang IDeref))) 37 | 38 | ;TODO how do we encode that nil is illegal to provide to Ports/Channels? 39 | ; Is it essential? 40 | 41 | ;;;;;;;;;;;;;;;;;;;; 42 | ;; Protocols 43 | 44 | (ann-protocol clojure.core.async.impl.protocols/Channel 45 | close! [impl/Channel -> nil]) 46 | 47 | (ann-protocol [[r :variance :covariant]] 48 | clojure.core.async.impl.protocols/ReadPort 49 | take! [(impl/ReadPort r) Lock 50 | -> (t/U nil (IDeref (t/U nil r)))]) 51 | 52 | (ann-protocol [[w :variance :contravariant]] 53 | clojure.core.async.impl.protocols/WritePort 54 | put! [(impl/WritePort w) w Lock 55 | -> (t/U nil (IDeref nil))]) 56 | 57 | (ann-protocol [[w :variance :contravariant] 58 | [r :variance :covariant]] 59 | clojure.core.async.impl.protocols/Buffer 60 | full? [(impl/Buffer w r) :-> t/Any] 61 | remove! [(impl/Buffer w r) :-> nil] 62 | add!* [(impl/Buffer w r) w :-> (impl/Buffer w r)] 63 | ) 64 | 65 | (ann-protocol clojure.core.async.impl.protocols/UnblockingBuffer) 66 | 67 | (ann-datatype [[w :variance :contravariant] 68 | [r :variance :covariant]] 69 | clojure.core.async.impl.channels.ManyToManyChannel 70 | [] 71 | :unchecked-ancestors [impl/Channel 72 | (impl/ReadPort r) 73 | (impl/WritePort w)]) 74 | 75 | ;;;;;;;;;;;;;;;;;;;; 76 | ;; Aliases 77 | 78 | (defalias 79 | ^{:forms '[(Port2 t t)]} 80 | Port2 81 | "A port that can write type w and read type r" 82 | (t/TFn [[w :variance :contravariant] 83 | [r :variance :covariant]] 84 | (t/I (impl/WritePort w) 85 | (impl/ReadPort r)))) 86 | 87 | (defalias 88 | ^{:forms '[(Port t)]} 89 | Port 90 | "A port that can read and write type x" 91 | (t/TFn [[x :variance :invariant]] 92 | (Port2 x x))) 93 | 94 | (defalias 95 | ^{:forms '[(Chan2 t t)]} 96 | Chan2 97 | "A core.async channel that can take type w and put type r" 98 | (t/TFn [[w :variance :contravariant] 99 | [r :variance :covariant]] 100 | (t/I (Port2 w r) 101 | impl/Channel))) 102 | 103 | (defalias 104 | ^{:forms '[(Chan t)]} 105 | Chan 106 | "A core.async channel" 107 | (t/TFn [[x :variance :invariant]] 108 | (Chan2 x x))) 109 | 110 | (defalias 111 | ^{:forms '[(ReadOnlyChan t)]} 112 | ReadOnlyChan 113 | "A core.async channel that statically disallows writes." 114 | (t/TFn [[r :variance :covariant]] 115 | (Chan2 t/Nothing r))) 116 | 117 | (defalias 118 | ^{:forms '[(ReadOnlyPort t)]} 119 | ReadOnlyPort 120 | "A read-only port that can read type x" 121 | (t/TFn [[t :variance :covariant]] 122 | (Port2 t/Nothing t))) 123 | 124 | (defalias 125 | ^{:forms '[(WriteOnlyPort t)]} 126 | WriteOnlyPort 127 | "A write-only port that can write type p" 128 | (t/TFn [[p :variance :contravariant]] 129 | (Port2 p t/Nothing))) 130 | 131 | (defalias 132 | ^{:forms '[TimeoutChan]} 133 | TimeoutChan 134 | "A timeout channel" 135 | (Chan t/Any)) 136 | 137 | (defalias 138 | ^{:forms '[(Buffer2 t t)]} 139 | Buffer2 140 | "A buffer of that can write type w and read type t." 141 | (t/TFn [[w :variance :contravariant] 142 | [r :variance :covariant]] 143 | (t/I (impl/Buffer w r) 144 | clojure.lang.Counted))) 145 | 146 | (defalias 147 | ^{:forms '[(Buffer t)]} 148 | Buffer 149 | "A buffer of type x." 150 | (t/TFn [[x :variance :invariant]] 151 | (Buffer2 x x))) 152 | 153 | (defalias 154 | ^{:forms '[(UnblockingBuffer2 t t)]} 155 | UnblockingBuffer2 156 | "An unblocking buffer that can write type w and read type t." 157 | (t/TFn [[w :variance :contravariant] 158 | [r :variance :covariant]] 159 | (t/I (Buffer2 w r) 160 | impl/UnblockingBuffer))) 161 | 162 | (defalias 163 | ^{:forms '[(UnblockingBuffer t)]} 164 | UnblockingBuffer 165 | "An unblocking buffer of type x." 166 | (t/TFn [[x :variance :invariant]] 167 | (UnblockingBuffer2 x x))) 168 | 169 | ;;;;;;;;;;;;;;;;;;;; 170 | ;; Var annotations 171 | 172 | (ann ^:no-check clojure.core.async/buffer (t/All [w r] [t/Int :-> (Buffer2 w r)])) 173 | (ann ^:no-check clojure.core.async/dropping-buffer (t/All [w r] [t/Int :-> (Buffer w r)])) 174 | (ann ^:no-check clojure.core.async/sliding-buffer (t/All [w r] [t/Int :-> (Buffer w r)])) 175 | 176 | (ann ^:no-check clojure.core.async/thread-call (t/All [x] [[:-> x] :-> (Chan x)])) 177 | 178 | (ann ^:no-check clojure.core.async/pipe 179 | (t/All [t] 180 | (t/IFn 181 | [(Chan t) (Chan t) :-> (Chan t)] 182 | [(Chan t) (Chan t) t/Any :-> (Chan t)]))) 183 | 184 | (ann ^:no-check clojure.core.async/timeout [t/Int :-> TimeoutChan]) 185 | 186 | ; TODO buffer must be supplied when xform is 187 | (ann ^:no-check clojure.core.async/chan 188 | (t/All [p t] 189 | (t/IFn [:-> (Chan2 p t)] 190 | [(t/U (Buffer2 p t) t/Int nil) :-> (Chan2 p t)] 191 | [(t/U (Buffer2 p t) t/Int nil) 192 | ; xform 193 | (t/U nil 194 | [[(Buffer2 p t) p :-> (Buffer2 p t)] 195 | :-> 196 | [(Buffer2 p t) p :-> (Buffer2 p t)]]) 197 | :-> (Chan2 p t)] 198 | [(t/U (Buffer2 p t) t/Int nil) 199 | ; xform 200 | (t/U nil 201 | [[(Buffer2 p t) p :-> (Buffer2 p t)] 202 | :-> 203 | [(Buffer2 p t) p :-> (Buffer2 p t)]]) 204 | ; ex-handler 205 | (t/U nil 206 | [Throwable :-> (t/U nil p)]) 207 | :-> (Chan2 p t)]))) 208 | 209 | (ann ^:no-check clojure.core.async.impl.ioc-macros/aget-object [AtomicReferenceArray t/Int :-> t/Any]) 210 | (ann ^:no-check clojure.core.async.impl.ioc-macros/aset-object [AtomicReferenceArray t/Any :-> nil]) 211 | (ann ^:no-check clojure.core.async.impl.ioc-macros/run-state-machine [AtomicReferenceArray :-> t/Any]) 212 | 213 | ;FIXME what is 2nd arg? 214 | (ann ^:no-check clojure.core.async.impl.ioc-macros/put! (t/All [x] [t/Int t/Any (Chan x) x :-> t/Any])) 215 | (ann ^:no-check clojure.core.async.impl.ioc-macros/return-chan (t/All [x] [AtomicReferenceArray x :-> (Chan x)])) 216 | 217 | (ann ^:no-check clojure.core.async/ (t/U nil t)])) 218 | ; should this use Port's? 219 | (ann ^:no-check clojure.core.async/ (t/U nil t)])) 220 | (ann ^:no-check clojure.core.async/>!! (t/All [p] [(Port2 p t/Any) p :-> t/Any])) 221 | (ann ^:no-check clojure.core.async/>! (t/All [p t] [(Port2 p t) p :-> (Port2 p t)])) 222 | (t/ann-many 223 | (t/All [x d] 224 | (t/IFn [(t/Seqable (t/U (Port x) '[(Port x) x])) 225 | & :mandatory {:default d} 226 | :optional {:priority (t/U nil true)} 227 | :-> (t/U '[d ':default] '[(t/U nil x) (Port x)])] 228 | [(t/Seqable (t/U (Port x) '[(Port x) x])) 229 | & :optional {:priority (t/U nil true)} 230 | :-> '[(t/U nil x) (Port x)]])) 231 | ^:no-check clojure.core.async/alts!! 232 | ^:no-check clojure.core.async/alts!) 233 | 234 | (ann ^:no-check clojure.core.async/close! [impl/Channel :-> nil]) 235 | 236 | (ann ^:no-check clojure.core.async.impl.dispatch/run [[:-> (ReadOnlyChan t/Any)] :-> Executor]) 237 | ;(ann clojure.core.async.impl.ioc-macros/async-chan-wrapper kV 238 | 239 | (ann ^:no-check clojure.core.async/put! 240 | (t/All [p] 241 | (t/IFn [(Port2 p t/Any) p :-> t/Any] 242 | [(Port2 p t/Any) p [t/Any :-> t/Any] :-> t/Any] 243 | [(Port2 p t/Any) p [t/Any :-> t/Any] t/Any :-> t/Any]))) 244 | 245 | (ann ^:no-check clojure.core.async/map< 246 | (t/All [t o] 247 | [[t -> o] 248 | (Chan2 t/Nothing t) 249 | :-> 250 | (Chan o)])) 251 | 252 | (ann ^:no-check clojure.core.async/map> 253 | (t/All [p t] 254 | [[t -> p] 255 | (Chan2 p t) 256 | :-> 257 | (Chan2 p t)])) 258 | 259 | ;(ann ^:no-check clojure.core.async/filter> 260 | ; (t/All [t t'] 261 | ; (t/IFn 262 | ; [[t :-> t/Any :filters {:then (is t' 0)}] (Chan2 t/Nothing t) :-> (Chan t')] 263 | ; [[t :-> t/Any] (Chan2 t/Nothing t) :-> (Chan t)]))) 264 | ; 265 | ;(ann ^:no-check clojure.core.async/remove> 266 | ; (t/All [p t] 267 | ; (t/IFn 268 | ; [[t :-> t/Any :filters {:then (! p 0)}] (Chan2 p t) :-> (Chan2 p t)] 269 | ; [[t :-> t/Any] (Chan2 p t) :-> (Chan2 p t)]))) 270 | ; 271 | ;(ann ^:no-check clojure.core.async/filter< 272 | ; (t/All [p t] 273 | ; (t/IFn 274 | ; [[t :-> t/Any :filters {:then (is p 0)}] (Chan2 t/Nothing t) :-> (Chan2 p t)] 275 | ; [[t :-> t/Any] (Chan2 t/Nothing t) :-> (Chan2 t t)]))) 276 | 277 | (ann ^:no-check clojure.core.async/onto-chan 278 | (t/All [x] 279 | [(Chan x) 280 | (t/U nil (t/Seqable x)) 281 | :-> 282 | (Chan t/Any)])) 283 | 284 | (ann ^:no-check clojure.core.async/to-chan 285 | (t/All [x] 286 | [(t/U nil (t/Seqable x)) 287 | :-> (Chan x)])) 288 | 289 | ;(ann ^:no-check clojure.core.async/map 290 | ; (All [x] 291 | ; [[x :-> y] 292 | ; (t/U nil (t/Seqable (Chan x))))) 293 | 294 | 295 | ;;;;;;;;;;;;;;;;;;;; 296 | ;; Typed wrappers 297 | 298 | (t/tc-ignore 299 | (defn ^:skip-wiki maybe-annotation [args] 300 | (let [t? (#{:-} (first args)) 301 | t (when t? (second args)) 302 | args (if t? 303 | (drop 2 args) 304 | args)] 305 | [t? t args])) 306 | ) 307 | 308 | (defmacro go 309 | "Like go but with optional annotations. Channel annotation defaults to Any. 310 | 311 | eg. 312 | (let [c (chan :- Str)] 313 | ;; same as (go :- t/Any ...) 314 | (go (a/>! c \"hello\")) 315 | (assert (= \"hello\" (a/ (f#) 336 | (ioc/aset-all! ioc/USER-START-IDX c# 337 | ioc/BINDINGS-IDX captured-bindings#))] 338 | (ioc/run-state-machine-wrapped state#))))) 339 | c#))) 340 | 341 | (defmacro go-loop 342 | "Like (go (t/loop ...))" 343 | [& body] 344 | (let [[t? t body] (maybe-annotation body)] 345 | (if t? 346 | `(go :- ~t (t/loop ~@body)) 347 | `(go (t/loop ~@body))))) 348 | 349 | (comment 350 | (t/cf 351 | (let [c (chan )] 352 | (go (a/>! c "hello")) 353 | (prn (a/!! c1 "hi") 363 | (a/>!! c2 "there"))) 364 | 365 | (t/cf 366 | (let [c1 (chan) 367 | c2 (chan :- t/Str)] 368 | (go (while true 369 | (let [[v ch] (a/alts! [c1 c2])] 370 | (println "Read" v "from" ch)))) 371 | (go (a/>! c1 "hi")) 372 | (go (a/>! c2 "there")))) 373 | 374 | ) 375 | 376 | (defmacro chan 377 | "Like chan but with optional type annotations. 378 | 379 | (chan :- t ...) creates a buffer that can read and write type t. 380 | Subsequent arguments are passed directly to clojure.core.async/chan. 381 | 382 | Note: 383 | (chan :- t ...) is the same as ((inst async/chan t) ...)" 384 | [& args] 385 | (let [[t? t args] (maybe-annotation args)] 386 | (if t? 387 | `((inst async/chan ~t ~t) ~@args) 388 | `(async/chan ~@args)))) 389 | 390 | (defmacro buffer 391 | "Like buffer but with optional type annotations. 392 | 393 | (buffer :- t ...) creates a buffer that can read and write type t. 394 | Subsequent arguments are passed directly to clojure.core.async/buffer. 395 | 396 | Note: (buffer :- t ...) is the same as ((inst buffer t) ...)" 397 | [& args] 398 | (let [[t? t args] (maybe-annotation args)] 399 | (if t? 400 | `((inst async/buffer ~t ~t) ~@args) 401 | `(async/buffer ~@args)))) 402 | 403 | (defmacro sliding-buffer 404 | "Like sliding-buffer but with optional type annotations. 405 | 406 | (sliding-buffer :- t ...) creates a sliding buffer that can read and write type t. 407 | Subsequent arguments are passed directly to clojure.core.async/sliding-buffer. 408 | 409 | Note: (sliding-buffer :- t ...) is the same as ((inst sliding-buffer t t) ...)" 410 | [& args] 411 | (let [[t? t args] (maybe-annotation args)] 412 | (if t? 413 | `((inst async/sliding-buffer ~t ~t) ~@args) 414 | `(async/sliding-buffer ~@args)))) 415 | 416 | 417 | (defmacro dropping-buffer 418 | "Like dropping-buffer but with optional type annotations. 419 | 420 | (dropping-buffer :- t ...) creates a dropping buffer that can read and write type t. 421 | Subsequent arguments are passed directly to clojure.core.async/dropping-buffer. 422 | 423 | Note: (dropping-buffer :- t ...) is the same as ((inst dropping-buffer t) ...)" 424 | [& args] 425 | (let [[t? t args] (maybe-annotation args)] 426 | (if t? 427 | `((inst async/dropping-buffer ~t ~t) ~@args) 428 | `(async/dropping-buffer ~@args)))) 429 | 430 | 431 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; 432 | ;; Deprecated 433 | 434 | (defmacro chan> 435 | "DEPRECATED: use chan" 436 | [t & args] 437 | (prn "DEPRECATED: chan>, use chan") 438 | `((inst async/chan ~t) ~@args)) 439 | 440 | (defmacro buffer> 441 | "DEPRECATED: use buffer" 442 | [t & args] 443 | (prn "DEPRECATED: buffer>, use buffer") 444 | `((inst async/buffer ~t) ~@args)) 445 | 446 | (defmacro sliding-buffer> 447 | "DEPRECATED: use sliding-buffer" 448 | [t & args] 449 | (prn "DEPRECATED: sliding-buffer>, use sliding-buffer") 450 | `((inst async/sliding-buffer ~t) ~@args)) 451 | 452 | (defmacro dropping-buffer> 453 | "DEPRECATED: use dropping-buffer" 454 | [t & args] 455 | (prn "DEPRECATED: dropping-buffer>, use dropping-buffer") 456 | `((inst async/dropping-buffer ~t) ~@args)) 457 | 458 | (defmacro go> 459 | "DEPRECATED: use go" 460 | [& body] 461 | (prn "DEPRECATED: go>, use go") 462 | `(go ~@body)) 463 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/type_contract.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 | ;flat contracts only 10 | (ns ^:no-doc ^:skip-wiki clojure.core.typed.type-contract 11 | (:require [clojure.core.typed.parse-ast :as ast] 12 | [clojure.core.typed.errors :as err] 13 | [clojure.core.typed.current-impl :as impl] 14 | [clojure.core.typed.ast-ops :as ops] 15 | [clojure.core.typed.contract :as con] 16 | ;used in contracts 17 | [clojure.set :as set])) 18 | 19 | (defn keyword-singleton? [{:keys [op val]}] 20 | (when ('#{:singleton} op) 21 | (keyword? val))) 22 | 23 | (def ^:dynamic *inside-rec* #{}) 24 | 25 | (defn ast->pred 26 | "Returns syntax representing a runtime predicate on the 27 | given type ast." 28 | [t] 29 | (letfn [(gen-inner [{:keys [op] :as t} arg] 30 | (case op 31 | (:F) (err/int-error "Cannot generate predicate for free variable") 32 | (:Poly) (err/int-error "Cannot generate predicate for polymorphic type") 33 | (:PolyDots) (err/int-error "Cannot generate predicate for dotted polymorphic type") 34 | (:Fn) (err/int-error "Cannot generate predicate for function type") 35 | (:TApp) (let [{:keys [rator rands]} t] 36 | (cond 37 | ;needs resolving 38 | (#{:Name} (:op rator)) 39 | (gen-inner (update-in t [:rator] ops/resolve-Name) arg) 40 | ;polymorphic class 41 | (#{:Class} (:op rator)) 42 | (let [{:keys [args pred] :as rcls} (get (impl/rclass-env) (:name rator)) 43 | _ (when-not rcls 44 | (err/int-error (str "Class does not take arguments: " 45 | (:name rator)))) 46 | _ (when-not (args (count rands)) 47 | (err/int-error (str "Wrong number of arguments to " 48 | (:name rator) ", expected " args 49 | " actual " (count rands)))) 50 | rands-args (repeatedly (count rands) gensym) 51 | rands-p (mapv (fn [ast gsym] 52 | `(fn [~gsym] ~(gen-inner ast gsym))) 53 | rands rands-args)] 54 | `(and (instance? ~(:name rator) ~arg) 55 | ~(apply pred arg rands-p))) 56 | ;substitute 57 | (#{:TFn} (:op rator)) 58 | (gen-inner (ops/instantiate-TFn rator rands) arg) 59 | :else 60 | (err/int-error (str "Don't know how to apply type: " (:form t))))) 61 | (:Class) `(instance? ~(:name t) ~arg) 62 | (:Name) 63 | (impl/impl-case 64 | :clojure (gen-inner (ops/resolve-Name t) arg) 65 | :cljs (err/int-error (str "TODO CLJS Name"))) 66 | ; (cond 67 | ; (empty? (:poly? t)) `(instance? ~(:the-class t) ~arg) 68 | ; :else (err/int-error (str "Cannot generate predicate for polymorphic Class"))) 69 | (:Any) `true 70 | ;TODO special case for union of HMap, and unions of constants 71 | (:U) `(or ~@(mapv gen-inner (:types t) (repeat arg))) 72 | (:I) `(and ~@(mapv gen-inner (:types t) (repeat arg))) 73 | (:HVec) `(and (vector? ~arg) 74 | ~(cond 75 | (:rest t) 76 | `(<= ~(count (:types t)) (count ~arg)) 77 | (:drest t) 78 | (err/int-error (str "Cannot generate predicate for dotted HVec")) 79 | :else 80 | `(== ~(count (:types t)) (count ~arg))) 81 | ~@(doall 82 | (map-indexed 83 | (fn [i t*] 84 | (let [vlocal (gensym "vlocal")] 85 | `(let [~vlocal (nth ~arg ~i)] 86 | ~(gen-inner t* vlocal)))) 87 | (:types t))) 88 | ~@(when (:rest t) 89 | (let [nfixed (count (:types t))] 90 | [`(let [rstvec# (subvec ~arg ~nfixed)] 91 | (every? ~(let [vlocal (gensym "vlocal")] 92 | `(fn [~vlocal] 93 | ~(gen-inner (:rest t) vlocal))) 94 | rstvec#))]))) 95 | (:CountRange) (let [cnt (gensym "cnt")] 96 | `(and (or (nil? ~arg) 97 | (coll? ~arg)) 98 | (let [~cnt (count ~arg)] 99 | (<= ~@(let [{:keys [lower upper]} t] 100 | (concat [lower cnt] 101 | (when upper 102 | [upper]))))))) 103 | (:singleton) (let [v (:val t)] 104 | (cond 105 | (nil? v) `(nil? ~arg) 106 | (symbol? v) `(= '~v ~arg) 107 | (keyword? v) `(identical? '~v ~arg) 108 | ((some-fn true? false?) v) `(identical? '~v ~arg) 109 | (number? v) `(when (number? ~arg) 110 | ; I think = models the type system's behaviour better than == 111 | (= '~v ~arg)) 112 | :else (err/int-error 113 | (str "Cannot generate predicate for value type: " v)))) 114 | (:HMap) (let [mandatory (apply hash-map (:mandatory t)) 115 | optional (apply hash-map (:optional t)) 116 | absent-keys (:absent-keys t) 117 | valgen (fn [tmap] 118 | (zipmap (map :val (keys tmap)) 119 | (mapv (fn [tsyn gi] 120 | `(fn [~gi] 121 | ~(gen-inner tsyn gi))) 122 | (vals tmap) 123 | (repeatedly (count tmap) gensym))))] 124 | `((impl/hmap-c? :mandatory ~(valgen mandatory) 125 | :optional ~(valgen optional) 126 | :absent-keys ~(set (map :val absent-keys)) 127 | :complete? ~(:complete? t)) 128 | ~arg)) 129 | (:Rec) (cond 130 | ;we're already inside this rec 131 | (contains? *inside-rec* (:unwrap-id t)) 132 | (let [{:keys [unwrap-id]} t] 133 | `(~unwrap-id ~arg)) 134 | 135 | :else 136 | (let [unwrap-id (gensym 'Rec-id) 137 | body (ops/unwrap-rec t unwrap-id) 138 | garg (gensym 'garg)] 139 | (binding [*inside-rec* (conj *inside-rec* unwrap-id)] 140 | `((fn ~unwrap-id 141 | [~garg] 142 | ~(gen-inner body garg)) 143 | ~arg)))) 144 | (err/int-error (str op " not supported in type->pred: " (:form t)))))] 145 | (let [arg (gensym "arg")] 146 | `(fn [~arg] 147 | (boolean 148 | ~(gen-inner t arg)))))) 149 | 150 | (defn ast->contract 151 | "Returns syntax representing a runtime predicate on the 152 | given type ast." 153 | [t] 154 | (letfn [(gen-inner [{:keys [op] :as t} arg] 155 | (case op 156 | (:F) (err/int-error "Cannot generate predicate for free variable") 157 | (:Poly) (err/int-error "Cannot generate predicate for polymorphic type") 158 | (:PolyDots) (err/int-error "Cannot generate predicate for dotted polymorphic type") 159 | (:Fn) (cond 160 | (== 1 (count (:arities t))) 161 | (let [{:keys [dom rng filter object flow rest drest] :as method} 162 | (first (:arities t))] 163 | (if (or rest drest filter object flow) 164 | (err/int-error "Cannot generate predicate for this function type") 165 | `(con/ifn-c ~(mapv #(gen-inner % arg) dom) 166 | ~(gen-inner rng arg)))) 167 | :else (err/int-error "Cannot generate predicate for function type")) 168 | (:TApp) (let [{:keys [rator rands]} t] 169 | (cond 170 | ;needs resolving 171 | (#{:Name} (:op rator)) 172 | (gen-inner (update-in t [:rator] ops/resolve-Name) arg) 173 | ;polymorphic class 174 | ;(#{:Class} (:op rator)) 175 | ; (let [{:keys [args pred] :as rcls} (get (impl/rclass-env) (:name rator)) 176 | ; _ (when-not rcls 177 | ; (err/int-error (str "Class does not take arguments: " 178 | ; (:name rator)))) 179 | ; _ (when-not (args (count rands)) 180 | ; (err/int-error (str "Wrong number of arguments to " 181 | ; (:name rator) ", expected " args 182 | ; " actual " (count rands)))) 183 | ; rands-args (repeatedly (count rands) gensym) 184 | ; rands-p (mapv (fn [ast gsym] 185 | ; `(fn [~gsym] ~(gen-inner ast gsym))) 186 | ; rands rands-args)] 187 | ; `(and (instance? ~(:name rator) ~arg) 188 | ; ~(apply pred arg rands-p))) 189 | ;substitute 190 | (#{:TFn} (:op rator)) 191 | (gen-inner (ops/instantiate-TFn rator rands) arg) 192 | :else 193 | (err/int-error (str "Don't know how to apply type: " (:form t))))) 194 | (:Class) `(con/instance-c 195 | (Class/forName ~(str (:name t)))) 196 | (:Name) 197 | (impl/impl-case 198 | :clojure (gen-inner (ops/resolve-Name t) arg) 199 | :cljs (err/int-error (str "TODO CLJS Name"))) 200 | ; (cond 201 | ; (empty? (:poly? t)) `(instance? ~(:the-class t) ~arg) 202 | ; :else (err/int-error (str "Cannot generate predicate for polymorphic Class"))) 203 | (:Any) `con/any-c 204 | ;TODO special case for union of HMap, and unions of constants 205 | (:U) `(con/or-c 206 | ;; TODO flatten unions, ensuring Names are resolved 207 | ~@(mapv #(gen-inner % arg) (:types t))) 208 | (:I) `(con/and-c 209 | ~@(mapv #(gen-inner % arg) (:types t))) 210 | ;(:HVec) `(and (vector? ~arg) 211 | ; ~(cond 212 | ; (:rest t) 213 | ; `(<= ~(count (:types t)) (count ~arg)) 214 | ; (:drest t) 215 | ; (err/int-error (str "Cannot generate predicate for dotted HVec")) 216 | ; :else 217 | ; `(== ~(count (:types t)) (count ~arg))) 218 | ; ~@(doall 219 | ; (map-indexed 220 | ; (fn [i t*] 221 | ; (let [vlocal (gensym "vlocal")] 222 | ; `(let [~vlocal (nth ~arg ~i)] 223 | ; ~(gen-inner t* vlocal)))) 224 | ; (:types t))) 225 | ; ~@(when (:rest t) 226 | ; (let [nfixed (count (:types t))] 227 | ; [`(let [rstvec# (subvec ~arg ~nfixed)] 228 | ; (every? ~(let [vlocal (gensym "vlocal")] 229 | ; `(fn [~vlocal] 230 | ; ~(gen-inner (:rest t) vlocal))) 231 | ; rstvec#))]))) 232 | (:CountRange) `(con/count-range-c ~(:lower t) ~(:upper t)) 233 | (:singleton) (let [v (:val t)] 234 | (cond 235 | (nil? v) `con/nil-c 236 | (symbol? v) `(con/equiv-c ~v) 237 | (keyword? v) `(con/identical-c ~v) 238 | ((some-fn true? false?) v) `(con/identical-c ~v) 239 | (number? v) ; I think = models the type system's behaviour better than == 240 | `(con/equiv-c ~v) 241 | 242 | :else (err/int-error 243 | (str "Cannot generate predicate for value type: " v)))) 244 | 245 | (:HMap) (let [mandatory (apply hash-map (:mandatory t)) 246 | optional (apply hash-map (:optional t)) 247 | absent-keys (:absent-keys t) 248 | congen (fn [tmap] 249 | (zipmap (map :val (keys tmap)) 250 | (map #(gen-inner % arg) (vals tmap))))] 251 | `(con/hmap-c :mandatory ~(congen mandatory) 252 | :optional ~(congen optional) 253 | :absent-keys ~(set (map :val absent-keys)) 254 | :complete? ~(:complete? t))) 255 | 256 | ;(:Rec) (cond 257 | ; ;we're already inside this rec 258 | ; (contains? *inside-rec* (:unwrap-id t)) 259 | ; (let [{:keys [unwrap-id]} t] 260 | ; `(~unwrap-id ~arg)) 261 | ; 262 | ; :else 263 | ; (let [unwrap-id (gensym 'Rec-id) 264 | ; body (ops/unwrap-rec t unwrap-id) 265 | ; garg (gensym 'garg)] 266 | ; (binding [*inside-rec* (conj *inside-rec* unwrap-id)] 267 | ; `((fn ~unwrap-id 268 | ; [~garg] 269 | ; ~(gen-inner body garg)) 270 | ; ~arg)))) 271 | (err/int-error (str op " not supported in type->pred: " (:form t)))))] 272 | (gen-inner t nil))) 273 | 274 | (defn type-syntax->pred [t] 275 | (impl/with-impl impl/clojure 276 | (-> (ast/parse t) 277 | ast->pred))) 278 | 279 | (defn type-syntax->contract [t] 280 | (impl/with-impl impl/clojure 281 | (-> (ast/parse t) 282 | ast->contract))) 283 | 284 | (comment 285 | (type-syntax->pred 'Any) 286 | (type-syntax->pred 'Nothing) 287 | (type-syntax->pred '(U Number Boolean)) 288 | 289 | (con/contract (type-syntax->contract 'nil) 1) 290 | 291 | (clojure.pprint/pprint (type-syntax->pred '(HMap :optional {:c Number}))) 292 | (clojure.pprint/pprint (type-syntax->pred '(HMap :mandatory {:c Number}))) 293 | (clojure.pprint/pprint (type-syntax->pred ''[Number])) 294 | (clojure.pprint/pprint (type-syntax->pred '(Rec [x] (U '[x] Number)))) 295 | (clojure.pprint/pprint (type-syntax->pred '(clojure.core.typed/Option Number))) 296 | 297 | (walk (type-syntax->pred '(HMap :optional {:c Number})) 298 | (fn [e] (prn 'pre (:op e))) 299 | (fn [e] (prn 'post (:op e)))) 300 | 301 | (def ast (ast/parse-clj '(HMap :optional {:c Number}))) 302 | 303 | (:children ast) 304 | 305 | (ops/walk ast 306 | (fn f [e] (prn 'pre (:op e))) 307 | (fn [e] (prn 'post (:op e)))) 308 | (ops/unwrap-rec (ast/parse-clj '(Rec [x] (U '[x] Number))) 'abc) 309 | ) 310 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/internal.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 ^:no-doc ^:skip-wiki clojure.core.typed.internal 10 | (:require [clojure.set :as set] 11 | [clojure.core.typed.contract-utils :as con])) 12 | 13 | (defn take-when 14 | "When pred is true of the head of seq, return [head tail]. Otherwise 15 | [nil seq]. Used as a helper for parsing optinal typed elements out 16 | of sequences. Say docstrings out of argument seqs." 17 | [pred seq] 18 | (if (pred (first seq)) 19 | ((juxt first rest) seq) 20 | [nil seq])) 21 | 22 | (defn parse-keyword-flat-map [forms] 23 | (loop [opts [] 24 | forms forms] 25 | (cond 26 | (keyword? (first forms)) 27 | (let [[kv forms] (split-at 2 forms)] 28 | (assert (#{2} (count kv)) 29 | (str "Missing keyword argument to: " (pr-str (first kv)))) 30 | (recur (apply conj opts kv) 31 | forms)) 32 | :else [opts forms]))) 33 | 34 | (defn parse-keyword-map [forms] 35 | (let [[flatopts forms] (parse-keyword-flat-map forms)] 36 | [(apply hash-map flatopts) forms])) 37 | 38 | (defn parse-fn* 39 | "(fn name? [[param :- type]* & [param :- type *]?] :- type? exprs*) 40 | (fn name? ([[param :- type]* & [param :- type *]?] :- type? exprs*)+)" 41 | [[_fn_ & forms :as form]] 42 | {:pre [(symbol? _fn_) 43 | #_(= "fn" (name _fn_))]} 44 | (let [[{poly :forall :as opts} forms] (parse-keyword-map forms) 45 | [name forms] (take-when symbol? forms) 46 | _ (assert (not (keyword? (first forms)))) 47 | single-arity-syntax? (vector? (first forms)) 48 | methods (if single-arity-syntax? 49 | (list forms) 50 | forms) 51 | parsed-methods (for [method methods] 52 | (merge-with merge 53 | (let [ann-params (first method)] 54 | (assert (vector? ann-params)) 55 | {:ann-params ann-params 56 | :original-method (vary-meta method #(merge (meta form) 57 | (meta ann-params) 58 | %))}) 59 | (loop [ann-params (first method) 60 | pvec (empty (first method)) ; an empty param vector with same metadata 61 | ann-info []] 62 | (cond 63 | (empty? ann-params) 64 | (let [[dom [amp rst]] (split-with (complement #{'&}) ann-info)] 65 | {:pvec pvec 66 | :ann (merge 67 | {:dom dom} 68 | (when (:rest rst) 69 | {:rest (:rest rst)}) 70 | (when (:drest rst) 71 | {:drest (:drest rst)}))}) 72 | 73 | ;rest param 74 | (#{'&} (first ann-params)) 75 | (let [[amp & ann-params] ann-params] 76 | (if (#{:-} (second ann-params)) 77 | (let [[p colon & rst-params] ann-params] 78 | (cond 79 | (#{'*} (second rst-params)) 80 | (let [[t star & after-rst] rst-params] 81 | (recur after-rst 82 | (conj pvec amp p) 83 | (conj ann-info amp {:rest {:type t}}))) 84 | 85 | (#{'...} (second rst-params)) 86 | (let [[pretype dots bound & after-rst] rst-params] 87 | (recur after-rst 88 | (conj pvec amp p) 89 | (conj ann-info amp {:drest {:pretype {:type pretype} 90 | :bound bound}}))) 91 | 92 | :else 93 | (throw (ex-info "Rest annotation must be followed with * or ..." {:form method})))) 94 | (let [[p & after-rst] ann-params] 95 | (recur after-rst 96 | (conj pvec amp p) 97 | (conj ann-info amp {:rest {:type 'clojure.core.typed/Any 98 | :default true}}))))) 99 | 100 | ;fixed param 101 | :else 102 | (if (#{:-} (second ann-params)) 103 | (let [[p colon t & rest-params] ann-params] 104 | (recur rest-params 105 | (conj pvec p) 106 | (conj ann-info {:type t}))) 107 | (let [[p & rest-params] ann-params] 108 | (recur rest-params 109 | (conj pvec p) 110 | (conj ann-info {:type 'clojure.core.typed/Any 111 | :default true})))))) 112 | (if (and (#{:-} (second method)) 113 | (<= 3 (count method))) 114 | (let [[param colon t & body] method] 115 | {:body body 116 | :ann {:rng {:type t}}}) 117 | (let [[param & body] method] 118 | {:body body 119 | :ann {:rng {:type 'clojure.core.typed/Any 120 | :default true}}})))) 121 | final-ann (mapv :ann parsed-methods)] 122 | #_(assert ((con/vec-c? 123 | (con/hmap-c? 124 | :dom (con/every-c? (con/hmap-c? :type (constantly true))) 125 | (con/optional :rest) (con/hmap-c? :type (constantly true)) 126 | :rng (some-fn (con/hmap-c? :default #{true}) 127 | (con/hmap-c? :type (constantly true))))) 128 | final-ann) 129 | final-ann) 130 | {:fn `(fn ~@(concat 131 | (when name 132 | [name]) 133 | (for [{:keys [body pvec]} parsed-methods] 134 | (apply list pvec body)))) 135 | :ann final-ann 136 | :poly poly 137 | :parsed-methods parsed-methods 138 | :name name 139 | :single-arity-syntax? single-arity-syntax?})) 140 | 141 | (defn parse-defn* [args] 142 | (let [[flatopt args] (parse-keyword-flat-map args) 143 | [name & args] args 144 | _ (assert (symbol? name) "defn name should be a symbol") 145 | [docstring args] (take-when string? args) 146 | [attr-map args] (take-when map? args)] 147 | {:name (vary-meta name merge 148 | {:arglists 149 | (list 'quote 150 | (if (vector? (first args)) ; arity = 1 151 | (list (first args)) 152 | (map first args)))} 153 | (when docstring {:doc docstring}) 154 | attr-map) 155 | :args (concat flatopt args)})) 156 | 157 | (defn parse-loop* 158 | [forms] 159 | (let [parsed-loop (merge 160 | (loop [ann-params (first forms) 161 | pvec [] 162 | ann-info []] 163 | (cond 164 | (empty? ann-params) 165 | {:pvec pvec 166 | :ann {:params ann-info}} 167 | 168 | :else 169 | (if (#{:-} (second ann-params)) 170 | (let [[p colon t init & rest-params] ann-params] 171 | (recur rest-params 172 | (conj pvec p init) 173 | (conj ann-info {:type t}))) 174 | (let [[p init & rest-params] ann-params] 175 | (recur rest-params 176 | (conj pvec p init) 177 | (conj ann-info {:type 'clojure.core.typed/Any 178 | :default true})))))) 179 | {:body (next forms)})] 180 | {:loop `(clojure.core/loop ~(:pvec parsed-loop) ~@(:body parsed-loop)) 181 | :ann (:ann parsed-loop)})) 182 | 183 | (defn binder-names [binder] 184 | {:post [(every? symbol? %)]} 185 | (map (fn [v] 186 | (if (vector? v) 187 | (first v) 188 | v)) 189 | binder)) 190 | 191 | (defn gen-ann-protocol [{:keys [name methods binder] :as dp-ann}] 192 | (let [tvars (set (binder-names binder)) 193 | this-type (if binder 194 | `(~name ~@(binder-names binder)) 195 | name)] 196 | `(clojure.core.typed/ann-protocol 197 | ~@(when binder 198 | [binder]) 199 | ~name 200 | ~@(mapcat (fn [{:keys [name arities poly]}] 201 | (let [localtvars (set (binder-names poly)) 202 | _ (assert (empty? (set/intersection localtvars 203 | tvars)) 204 | "Shadowing a protocol type variable in a method is disallowed") 205 | fn-type `(clojure.core.typed/IFn 206 | ~@(map (fn [{:keys [ptypes ret]}] 207 | (let [[provided-this & argts] ptypes 208 | ; if programmer provides the default 'this' type, use that, 209 | ; otherwise use the current protocol. 210 | actual-this (if (:default provided-this) 211 | this-type 212 | (:type provided-this))] 213 | `[~@(concat [actual-this] (map :type argts)) ~'-> ~(:type ret)])) 214 | arities))] 215 | [name (if poly 216 | `(clojure.core.typed/All ~poly ~fn-type) 217 | fn-type)])) 218 | methods)))) 219 | 220 | 221 | (defn parse-defprotocol* 222 | [forms] 223 | (let [[binder forms] (take-when vector? forms) 224 | [pname & typed-decl-methods] forms 225 | [pdoc typed-decl-methods] (take-when string? typed-decl-methods) 226 | parse-pvec (fn [pvec] ; parse parameter vectors 227 | {:pre [(vector? pvec)] 228 | :post [((con/hmap-c? :actual vector? 229 | :ptypes vector?) 230 | %)]} 231 | (loop [pvec pvec 232 | actual (empty pvec) ; empty vector with same metadata as pvec 233 | ptypes []] 234 | (assert (every? vector? [actual ptypes])) 235 | (cond 236 | (empty? pvec) {:ptypes ptypes :actual actual} 237 | :else (if (#{:-} (second pvec)) 238 | (let [_ (assert (#{3} (count (take 3 pvec))) 239 | "Missing type annotation after :-") 240 | [b colon t & rst] pvec] 241 | (recur rst 242 | (conj actual b) 243 | (conj ptypes {:type t}))) 244 | (let [_ (assert (seq pvec)) 245 | [b & rst] pvec] 246 | (recur rst 247 | (conj actual b) 248 | (conj ptypes {:type 'clojure.core.typed/Any 249 | :default true}))))))) 250 | actual-decl-methods (for [m typed-decl-methods] 251 | (let [[poly rst] (take-when vector? m) 252 | [name & dvecs] rst] 253 | (assert (symbol? name) (str "defprotocol method name must be a symbol: " pname)) 254 | (loop [dvecs dvecs 255 | arities []] 256 | (cond 257 | (or (empty? dvecs) 258 | (string? (first dvecs))) 259 | (merge {:poly poly 260 | :name name 261 | :arities arities} 262 | (when (string? (first dvecs)) 263 | {:doc (first dvecs)})) 264 | 265 | :else (if (#{:-} (second dvecs)) 266 | (let [_ (assert (#{3} (count (take 3 dvecs))) 267 | "Missing type annotation after :-") 268 | [v colon t & rst] dvecs 269 | {:keys [ptypes actual]} (parse-pvec v)] 270 | (recur rst 271 | (conj arities {:ret {:type t} 272 | :ptypes ptypes 273 | :actual actual}))) 274 | (let [_ (assert (seq dvecs)) 275 | [v & rst] dvecs 276 | {:keys [ptypes actual]} (parse-pvec v)] 277 | (recur rst 278 | (conj arities {:ret {:type 'clojure.core.typed/Any 279 | :default true} 280 | :ptypes ptypes 281 | :actual actual})))))))) 282 | ann {:binder binder 283 | :name pname 284 | :methods (map #(dissoc % :doc) actual-decl-methods)}] 285 | {:defprotocol `(clojure.core/defprotocol 286 | ~pname 287 | ~@(when pdoc [pdoc]) 288 | ~@(map (fn [{:keys [name arities doc]}] 289 | `(~name ~@(concat ; prefer left-most arities if grouped duplicates 290 | (reduce 291 | (fn [ret current] 292 | (if (= (count current) (count (last ret))) 293 | ret 294 | (conj ret current))) 295 | [] 296 | (map :actual arities)) 297 | (when doc 298 | [doc])))) 299 | actual-decl-methods)) 300 | :ann-protocol (gen-ann-protocol ann)})) 301 | 302 | (defn parse-let* 303 | [[bvec & forms]] 304 | (let [actual-bvec (loop [bvec bvec 305 | actual-bvec (empty bvec)] ; empty vector with same metadata as bvec 306 | (assert (vector? actual-bvec)) 307 | (cond 308 | (empty? bvec) actual-bvec 309 | :else (if (#{:-} (second bvec)) 310 | (let [_ (assert (#{4} (count (take 4 bvec))) 311 | "Incorrect forms following :-") 312 | [v colon t init & rst] bvec] 313 | (recur rst 314 | (conj actual-bvec v `(clojure.core.typed/ann-form ~init ~t)))) 315 | (let [_ (assert (#{2} (count (take 2 bvec))) 316 | "No init found for local binding") 317 | [v init & rst] bvec] 318 | (recur rst 319 | (conj actual-bvec v init))))))] 320 | {:let `(clojure.core/let ~actual-bvec ~@forms)})) 321 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/core/typed/contract.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.contract 10 | "A contract system a la racket/contract. 11 | 12 | Main entry point is the `contract` macro." 13 | #?(:cljs (:require-macros [clojure.core.typed.contract :refer [contract instance-c]])) 14 | (:require [clojure.set :as set])) 15 | 16 | ;; A contract, the first argument to the `contract` macro 17 | ;; - name : Symbol 18 | ;; a name for the contract, eg. 'int-c 19 | ;; - first-order : [Any -> Any] 20 | ;; first order (flat) predicate for the current contract. 21 | ;; Must return true for all inputs that passes the projection, but 22 | ;; can also return true for values that fail the contract. 23 | ;; eg. ifn? for [Int -> Int] 24 | ;; - projection : [Blame -> [Any -> Any]] 25 | ;; A curried function that does the actual contract checking. 26 | ;; Takes a Blame object and a value, and returns a new value that 27 | ;; adheres to the current Contract object, otherwise blames Blame. 28 | ;; eg. for the int-c contract: 29 | ;; (fn [b] 30 | ;; (fn [x] 31 | ;; (if (integer? x) 32 | ;; x 33 | ;; (throw-blame b)))) 34 | ;; - flat? : Boolean 35 | ;; True if this is a flat contract, ie. first-order returns true 36 | ;; for exactly the same values that pass the projection function. 37 | (defrecord Contract [name first-order projection flat?]) 38 | 39 | ;; A Blame object 40 | ;; - positive : (U String Symbol) 41 | ;; Positive blame party. 42 | ;; eg. "clojure.core.typed" 43 | ;; - negative : (U String Symbol) 44 | ;; Negative blame party. 45 | ;; eg. "Not clojure.core.typed" 46 | ;; - name (unused) 47 | ;; - contract (unused) 48 | ;; - file : (U nil String) 49 | ;; File name where contract occurs. 50 | ;; - line, column : (U Integer nil) 51 | ;; Line/column positions to blame. 52 | (defrecord Blame [positive negative name contract file line column]) 53 | 54 | #_ (ann throw-blame [Blame -> Nothing]) 55 | (defn throw-blame 56 | "Throw a blame object 57 | 58 | [Blame -> Nothing]" 59 | [{:keys [message positive negative file line column] :as b}] 60 | (throw 61 | (ex-info 62 | (str message "\n" 63 | "Positive blame: " positive "\n" 64 | "Negative blame: " negative "\n" 65 | "File: " file "\n" 66 | "Line: " line "\n" 67 | "Column: " column "\n") 68 | {:blame b}))) 69 | 70 | #_(ann-many [& :optional {:name (U Symbol String) 71 | :first-order [Any :-> Any] 72 | :projection [Blame :-> [Any :-> Any]] 73 | :flat? Boolean} 74 | :-> Contract] 75 | make-contract 76 | make-flat-contract) 77 | (defn make-contract 78 | "Make a new contract. 79 | 80 | Keyword arguments: (see Contract datatype for more details) 81 | - :name Name of the contract, (U Symbol String) 82 | - :first-order First-order predicate for this contract, [Any -> Any] 83 | - :projection Curried function taking blame and the value to check, 84 | and returns a new checked value, or throws blame. 85 | [Blame -> [Any -> Any]] 86 | - :flat? True if this is a flat contract, Boolean" 87 | [& {:keys [name first-order projection flat?] 88 | :or {flat? false}}] 89 | (let [name (or name 90 | 'anonymous-contract) 91 | first-order (or first-order 92 | (fn [x] true)) 93 | projection (or projection 94 | (fn [b] 95 | (fn [x] 96 | (if (first-order x) 97 | x 98 | (throw-blame b)))))] 99 | (map->Contract 100 | {:name name 101 | :first-order first-order 102 | :projection projection 103 | :flat? flat?}))) 104 | 105 | 106 | (defn make-flat-contract 107 | "Calls `make-contract` but also passes `:flat? true` as the first arguments." 108 | [& args] 109 | (apply make-contract :flat? true args)) 110 | 111 | #_(ann make-blame [& :optional {:message String 112 | :positive (U String Symbol) 113 | :negative (U String Symbol) 114 | :file (U Str nil) 115 | :line (U Int nil) 116 | :column (U Int nil)} 117 | :-> Blame]) 118 | (defn make-blame 119 | "Make a new blame object. 120 | 121 | Keyword arguments: 122 | - :message A string message, String 123 | - :positive Positive blame party, (U String Symbol) 124 | - :negative Negative blame party, (U String Symbol) 125 | - :file File that contains contract, (U Str nil) 126 | - :line Line where contract occurs, (U Int nil) 127 | - :column Column where contract occurs, (U Int nil)" 128 | [& {:as bls}] 129 | (map->Blame bls)) 130 | 131 | #?(:clj 132 | (defmacro contract 133 | "Check a contract against a value, with an optional Blame object. 134 | 135 | (IFn [Contract Any -> Any] 136 | [Contract Any Blame -> Any])" 137 | ([c x] `(contract ~c ~x nil)) 138 | ([c x b] 139 | `(((:projection ~c) 140 | (or ~b 141 | (make-blame :positive ~(str (ns-name *ns*)) 142 | :negative ~(str "Not " (ns-name *ns*)) 143 | :file ~*file* 144 | :line ~(or (-> &form meta :line) 145 | @Compiler/LINE) 146 | :column ~(or (-> &form meta :column) 147 | @Compiler/COLUMN)))) 148 | ~x)))) 149 | 150 | #_(ann swap-blame [Blame :-> Blame]) 151 | (defn swap-blame 152 | "Swap a blame object's blame parties. 153 | 154 | [Blame -> Blame]" 155 | [x] 156 | {:pre [(instance? Blame x)] 157 | :post [(instance? Blame %)]} 158 | (-> x 159 | (assoc :positive (:negative x)) 160 | (assoc :negative (:positive x)))) 161 | 162 | #_(ann int-c Contract) 163 | (def int-c 164 | "Flat contract for values that pass `integer?`." 165 | (make-flat-contract :name 'int-c :first-order integer?)) 166 | 167 | ;; macro to allow instance? specialisation 168 | #?(:clj 169 | (defmacro instance-c 170 | "Flat contracts for instance? checks on Class's." 171 | [c] 172 | `(make-flat-contract :name (str ~c) 173 | :first-order #(instance? ~c %)))) 174 | 175 | #_(ann Object-c Contract) 176 | (def Object-c (instance-c Object)) 177 | 178 | #_(ann flat-val-c [Sym [Any -> Any] :-> Contract]) 179 | (defn flat-val-c 180 | "Contract generation for flat predicates." 181 | [name pred] 182 | (make-flat-contract :name name :first-order pred)) 183 | 184 | #_(ann-many Contract 185 | nil-c 186 | true-c 187 | false-c) 188 | (def nil-c 189 | "Contract that checks for `nil`." 190 | (flat-val-c 'nil-c nil?)) 191 | (def true-c 192 | "Contract that checks for `true`." 193 | (flat-val-c 'true-c true?)) 194 | (def false-c 195 | "Contract that checks for `false`." 196 | (flat-val-c 'false-c false?)) 197 | 198 | #_(ann any-c Contract) 199 | (def any-c 200 | "Contract that allows any value." 201 | (make-flat-contract :name any-c)) 202 | 203 | #_(ann count-range-c 204 | (IFn [Int -> Contract] 205 | [Int (U nil Int) -> Contract])) 206 | (defn count-range-c 207 | "Returns a flat contract that allows values with `count` 208 | greater-or-equal-to lower, and less-or-equal-to upper. 209 | Upper can be nil for positive infinity. 210 | 211 | (IFn [Int -> Contract] 212 | [Int (U nil Int) -> Contract]) 213 | 214 | eg. (count-range-c 0 10) 215 | (count-range-c 0 nil)" 216 | ([lower] (count-range-c lower nil)) 217 | ([lower upper] 218 | (make-flat-contract :name 'count-range-c 219 | :first-order (fn [x] 220 | (and (or (nil? x) 221 | (coll? x)) 222 | (if upper 223 | (<= lower (count x) upper) 224 | (<= lower (count x)))))))) 225 | 226 | #_(ann equiv-c [Any -> Contract]) 227 | (defn equiv-c 228 | "Returns a flat contract that returns true if a value is `=` 229 | to y. 230 | 231 | [Any -> Contract]" 232 | [y] 233 | (make-flat-contract :name 'equiv-c 234 | :first-order (fn [x] 235 | (= x y)))) 236 | 237 | #_(ann identical-c [Any -> Contract]) 238 | (defn identical-c 239 | "Returns a flat contract that returns true if a value is `identical?` 240 | to y. 241 | 242 | [Any -> Contract]" 243 | [y] 244 | (make-flat-contract :name 'identical-c 245 | :first-order (fn [x] 246 | (identical? x y)))) 247 | 248 | 249 | #_(ann ifn-c [(Vec Contract) Contract -> Contract]) 250 | (defn ifn-c 251 | "Returns a function contract that checks a function has 252 | fixed domain that passes contracts `cs` and return value 253 | that passes contact `c2`. 254 | 255 | [(Vec Contract) Contract -> Contract] 256 | 257 | eg. (ifn-c [int-c] int-c) ;; [Int -> Int] contract" 258 | [cs c2] 259 | {:pre [(every? #(instance? Contract %) cs) 260 | (instance? Contract c2)] 261 | :post [(instance? Contract %)]} 262 | (make-contract 263 | :name 'ifn-c 264 | :first-order ifn? 265 | :projection (fn [b] 266 | (fn [f] 267 | ; returning a contracted function 268 | (contract (make-flat-contract 269 | :name 'ifn? 270 | :first-order ifn?) 271 | f 272 | b) 273 | (with-meta 274 | (fn [& xs] 275 | (contract c2 276 | (apply f 277 | (map #(contract %1 278 | %2 279 | (swap-blame b)) 280 | cs 281 | xs)) 282 | b)) 283 | (if (fn? f) 284 | (meta f) 285 | nil)))))) 286 | 287 | (declare ->CheckedISeq) 288 | 289 | (deftype CheckedISeq [s c b] 290 | clojure.lang.Sequential 291 | clojure.lang.ISeq 292 | (first [this] 293 | (contract c (first s) b)) 294 | (next [this] 295 | (when-let [n (next s)] 296 | (->CheckedISeq n c b))) 297 | (cons [this x] 298 | (->CheckedISeq (conj s x) c b)) 299 | (empty [this] 300 | (empty s)) 301 | (seq [this] 302 | (when (seq s) 303 | this)) 304 | (equiv [this o] 305 | (if (or (not (instance? clojure.lang.Sequential o)) 306 | (not (instance? java.util.List o))) 307 | false 308 | (loop [ms this 309 | s (seq o)] 310 | (if (and s (= (first ms) 311 | (first s))) 312 | (recur (next ms) (next s)) 313 | (not ms)))))) 314 | 315 | 316 | #_(ann seqable-c [Contract :-> Contract]) 317 | (defn seqable-c 318 | "Alpha - subject to change. 319 | 320 | Returns a contract that checks Seqable things. 321 | 322 | [Contract -> Contract]" 323 | [c] 324 | {:pre [(instance? Contract c)] 325 | :post [(instance? Contract %)]} 326 | (make-contract 327 | :name 'seqable-c 328 | :projection (fn [b] 329 | (fn [s] 330 | (contract Object-c s b) 331 | (reify 332 | clojure.lang.Seqable 333 | (seq [this] 334 | (->CheckedISeq s c b))))))) 335 | 336 | #_(ann or-c [Contract * :-> Contract]) 337 | (defn or-c 338 | "Returns a contract that checks a value passes at least 339 | one of the contracts `cs`. 340 | 341 | Any number of flat contracts may be passed to or-c. However, 342 | if more than one higher-order contract is provided, each time 343 | this contract is used, at most *one* may pass its first-order 344 | predicate. 345 | 346 | For example, (or-c (ifn-c [int-c] int-c) (ifn-c [] int-c)) 347 | cannot be checked against `clojure.core/+` because 348 | the first-order check for both contracts (`ifn?`) passes. 349 | 350 | [Contract * -> Contract] 351 | 352 | eg. (or-c int-c nil-c) ;; (U Int nil) 353 | (or-c int-c (ifn-c [int-c] int-c)) ;; (U Int [Int -> Int]) 354 | " 355 | [& cs] 356 | {:pre [(every? #(instance? Contract %) cs)] 357 | :post [(instance? Contract %)]} 358 | (let [{flat true hoc false} (group-by :flat? cs) 359 | ;_ (prn "flat" (mapv :name flat)) 360 | ;_ (prn "hoc" (mapv :name hoc)) 361 | flat-checks (apply some-fn (or (seq (map :first-order flat)) 362 | ;; (U) always fails 363 | [(fn [_] false)])) 364 | choose-hoc 365 | (fn [x b] 366 | {:pre [(instance? Blame b)]} 367 | (let [hs (filter (fn [{:keys [first-order]}] 368 | (first-order x)) 369 | hoc)] 370 | ;; don't realise more than needed, though chunking will 371 | ;; probably negate most of the benefit. 372 | (cond 373 | ;; more than one higher-order contract matched 374 | (second hs) (throw-blame b) 375 | ;; exactly one matched 376 | (first hs) (contract (first hs) x b) 377 | ;; no contracts matched 378 | :else (throw-blame b))))] 379 | (make-contract 380 | :name 'or-c 381 | :flat? (not (seq hoc)) 382 | ; needed? 383 | :first-order (apply some-fn flat-checks (map :first-order hoc)) 384 | :projection (fn [b] 385 | (fn [x] 386 | (if (flat-checks x) 387 | x 388 | (choose-hoc x b))))))) 389 | 390 | #_(ann and-c [Contract * :-> Contract]) 391 | (defn and-c 392 | "Returns a contract that ensures a value passes each contract `cs`. 393 | 394 | At most *one* higher-order contract may be passed to `and-c`, and 395 | any number of flat contracts. 396 | 397 | [Contract * -> Contract] 398 | 399 | eg. (and-c (instance-c Boolean) true-c) ;; (I Boolean true)" 400 | [& cs] 401 | {:pre [(every? #(instance? Contract %) cs)] 402 | :post [(instance? Contract %)]} 403 | (let [{flat true hoc false} (group-by (comp boolean :flat?) cs) 404 | ;_ (prn "flat" (mapv :name flat)) 405 | ;_ (prn "hoc" (mapv :name hoc)) 406 | ] 407 | (if (< (count hoc) 2) 408 | (let [h (first hoc)] 409 | (make-contract 410 | :name 'and-c 411 | :flat? (not h) 412 | :first-order (apply every-pred (or (seq (map :first-order cs)) 413 | ;; (I) always passes 414 | (fn [_] true))) 415 | :projection (fn [b] 416 | (fn [x] 417 | (doseq [f flat] 418 | (contract f x b)) 419 | ;; could stage this conditional 420 | (if h 421 | (contract h x b) 422 | x))))) 423 | (throw (ex-info 424 | "Cannot create and-c contract with more than one higher-order contract" 425 | {:hoc (map :name hoc)}))))) 426 | 427 | #_(ann hmap-c [& :optional {:mandatory (Map Keyword Contract) 428 | :optional (Map Keyword Contract) 429 | :absent-keys (Set Keyword) 430 | :complete? Boolean} 431 | :-> Contract]) 432 | (defn hmap-c 433 | "Takes a map of mandatory and optional entry contracts, 434 | a set of absent keys, and :complete? true if this is a fully 435 | specified map. Intended to work with keyword keys, but should 436 | work with any keys looked up via =." 437 | [& {:keys [mandatory optional absent-keys complete?] 438 | :or {absent-keys #{} 439 | mandatory {} 440 | optional {} 441 | complete? false}}] 442 | (let [flat? (every? (comp :flat? val) (concat mandatory optional)) 443 | ;_ (prn "flat?" flat?) 444 | mkeys (set (keys mandatory)) 445 | okeys (set (keys optional)) 446 | check-absent? 447 | (if complete? 448 | (fn [m] 449 | {:pre [(map? m)]} 450 | true) 451 | (fn [m] 452 | {:pre [(map? m)]} 453 | (empty? (set/intersection (set (keys m)) absent-keys)))) 454 | check-completeness? 455 | (if complete? 456 | (fn [m] 457 | {:pre [(map? m)]} 458 | ;; only the mandatory or optional entries are allowed 459 | (empty? (set/difference (set (keys m)) 460 | mkeys 461 | okeys))) 462 | (fn [m] 463 | {:pre [(map? m)]} 464 | true))] 465 | (make-contract :name 'hmap-c 466 | :flat? flat? 467 | :first-order (fn [m] 468 | (and 469 | (map? m) 470 | (check-completeness? m) 471 | (check-absent? m) 472 | (every? (fn [[k {:keys [first-order]}]] 473 | (and (contains? m k) 474 | (first-order (get m k)))) 475 | mandatory) 476 | (every? (fn [[k {:keys [first-order]}]] 477 | (or (not (contains? m k)) 478 | (first-order (get m k)))) 479 | optional))) 480 | :projection (fn [b] 481 | (fn [m] 482 | (contract (make-flat-contract 483 | :name 'map? 484 | :first-order map?) 485 | m 486 | b) 487 | (contract (make-flat-contract 488 | :name 'hmap-completeness-check 489 | :first-order check-completeness?) 490 | m 491 | b) 492 | (contract (make-flat-contract 493 | :name 'hmap-absent-check 494 | :first-order check-absent?) 495 | m 496 | b) 497 | (as-> 498 | m ;; the expression 499 | m ;; the name to thread through 500 | 501 | ;; apply mandatory checks 502 | (reduce-kv (fn [m k c] 503 | {:pre [(map? m)] 504 | :post [(map? m)]} 505 | (if (not (contains? m k)) 506 | (throw-blame 507 | (assoc b 508 | :message (str k " key is missing"))) 509 | (if (:flat? c) 510 | (do (contract c (get m k) b) ;; could be done asynchronously 511 | m) 512 | (update m k #(contract c % b))))) 513 | m ;; the current map 514 | mandatory) 515 | 516 | ;; apply optional checks 517 | (reduce-kv (fn [m k c] 518 | {:pre [(map? m)] 519 | :post [(map? m)]} 520 | (if (not (contains? m k)) 521 | m 522 | (if (:flat? c) 523 | (do (contract c (get m k) b) 524 | m) 525 | (update m k #(contract c % b))))) 526 | m ;; the current map 527 | optional) 528 | 529 | ;; return the accumulated map 530 | m)))))) 531 | --------------------------------------------------------------------------------