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 | -------------------------------------------------------------------------------- /src/test/clojure/clojure/test_clojure/spec_test.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey. All rights reserved. 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.test-clojure.spec-test ;;; renamed as spec-test for test-runner compat 10 | (:require [clojure.spec.alpha :as s] 11 | [clojure.spec.gen.alpha :as gen] 12 | [clojure.spec.test.alpha :as stest] 13 | [clojure.test :refer :all])) 14 | 15 | (set! *warn-on-reflection* true) 16 | 17 | (defmacro result-or-ex [x] 18 | `(try 19 | ~x 20 | (catch Exception t# ;;; Throwable 21 | (.FullName (class t#))))) ;;; .getName 22 | 23 | (def even-count? #(even? (count %))) 24 | 25 | (defn submap? 26 | "Is m1 a subset of m2?" 27 | [m1 m2] 28 | (if (and (map? m1) (map? m2)) 29 | (every? (fn [[k v]] (and (contains? m2 k) 30 | (submap? v (get m2 k)))) 31 | m1) 32 | (= m1 m2))) 33 | 34 | (deftest conform-explain 35 | (let [a (s/and #(> % 5) #(< % 10)) 36 | o (s/or :s string? :k keyword?) 37 | c (s/cat :a string? :b keyword?) 38 | either (s/alt :a string? :b keyword?) 39 | star (s/* keyword?) 40 | plus (s/+ keyword?) 41 | opt (s/? keyword?) 42 | andre (s/& (s/* keyword?) even-count?) 43 | andre2 (s/& (s/* keyword?) #{[:a]}) 44 | m (s/map-of keyword? string?) 45 | mkeys (s/map-of (s/and keyword? (s/conformer name)) any?) 46 | mkeys2 (s/map-of (s/and keyword? (s/conformer name)) any? :conform-keys true) 47 | s (s/coll-of (s/spec (s/cat :tag keyword? :val any?)) :kind list?) 48 | v (s/coll-of keyword? :kind vector?) 49 | coll (s/coll-of keyword?) 50 | lrange (s/int-in 7 42) 51 | drange (s/double-in :infinite? false :NaN? false :min 3.1 :max 3.2) 52 | irange (s/inst-in #inst "1939" #inst "1946") 53 | ] 54 | (are [spec x conformed ed] 55 | (let [co (result-or-ex (s/conform spec x)) 56 | e (result-or-ex (::s/problems (s/explain-data spec x)))] 57 | (when (not= conformed co) (println "conform fail\n\texpect=" conformed "\n\tactual=" co)) 58 | (when (not (every? true? (map submap? ed e))) 59 | (println "explain failures\n\texpect=" ed "\n\tactual failures=" e "\n\tsubmap?=" (map submap? ed e))) 60 | (and (= conformed co) (every? true? (map submap? ed e)))) 61 | 62 | lrange 7 7 nil 63 | lrange 8 8 nil 64 | lrange 42 ::s/invalid [{:pred '(clojure.core/fn [%] (clojure.spec.alpha/int-in-range? 7 42 %)), :val 42}] 65 | 66 | irange #inst "1938" ::s/invalid [{:pred '(clojure.core/fn [%] (clojure.spec.alpha/inst-in-range? #inst "1939-01-01T00:00:00.000-00:00" #inst "1946-01-01T00:00:00.000-00:00" %)), :val #inst "1938"}] 67 | irange #inst "1942" #inst "1942" nil 68 | irange #inst "1946" ::s/invalid [{:pred '(clojure.core/fn [%] (clojure.spec.alpha/inst-in-range? #inst "1939-01-01T00:00:00.000-00:00" #inst "1946-01-01T00:00:00.000-00:00" %)), :val #inst "1946"}] 69 | 70 | drange 3.0 ::s/invalid [{:pred '(clojure.core/fn [%] (clojure.core/<= 3.1 %)), :val 3.0}] 71 | drange 3.1 3.1 nil 72 | drange 3.2 3.2 nil 73 | drange Double/PositiveInfinity ::s/invalid [{:pred '(clojure.core/fn [%] (clojure.core/not (Double/IsInfinity %))), :val Double/PositiveInfinity}] ;;; Double/POSITIVE_INFINITY Double/isInfinite Double/POSITIVE_INFINITY 74 | ;; can't use equality-based test for Double/NaN 75 | ;; drange Double/NaN ::s/invalid {[] {:pred '(clojure.core/fn [%] (clojure.core/not (Double/isNaN %))), :val Double/NaN}} 76 | 77 | keyword? :k :k nil 78 | keyword? nil ::s/invalid [{:pred `keyword? :val nil}] 79 | keyword? "abc" ::s/invalid [{:pred `keyword? :val "abc"}] 80 | 81 | a 6 6 nil 82 | a 3 ::s/invalid '[{:pred (clojure.core/fn [%] (clojure.core/> % 5)), :val 3}] 83 | a 20 ::s/invalid '[{:pred (clojure.core/fn [%] (clojure.core/< % 10)), :val 20}] 84 | a nil "System.NullReferenceException" "System.NullReferenceException" ;;; "java.lang.NullPointerException" "java.lang.NullPointerException" 85 | a :k "System.InvalidCastException" "System.InvalidCastException" ;;; "java.lang.ClassCastException" "java.lang.ClassCastException" 86 | 87 | o "a" [:s "a"] nil 88 | o :a [:k :a] nil 89 | o 'a ::s/invalid '[{:pred clojure.core/string?, :val a, :path [:s]} {:pred clojure.core/keyword?, :val a :path [:k]}] 90 | 91 | c nil ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/string?, :val (), :path [:a]}] 92 | c [] ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/string?, :val (), :path [:a]}] 93 | c [:a] ::s/invalid '[{:pred clojure.core/string?, :val :a, :path [:a], :in [0]}] 94 | c ["a"] ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/keyword?, :val (), :path [:b]}] 95 | c ["s" :k] '{:a "s" :b :k} nil 96 | c ["s" :k 5] ::s/invalid '[{:reason "Extra input", :pred (clojure.spec.alpha/cat :a clojure.core/string? :b clojure.core/keyword?), :val (5)}] 97 | (s/cat) nil {} nil 98 | (s/cat) [5] ::s/invalid '[{:reason "Extra input", :pred (clojure.spec.alpha/cat), :val (5), :in [0]}] 99 | 100 | either nil ::s/invalid '[{:reason "Insufficient input", :pred (clojure.spec.alpha/alt :a clojure.core/string? :b clojure.core/keyword?), :val () :via []}] 101 | either [] ::s/invalid '[{:reason "Insufficient input", :pred (clojure.spec.alpha/alt :a clojure.core/string? :b clojure.core/keyword?), :val () :via []}] 102 | either [:k] [:b :k] nil 103 | either ["s"] [:a "s"] nil 104 | either [:b "s"] ::s/invalid '[{:reason "Extra input", :pred (clojure.spec.alpha/alt :a clojure.core/string? :b clojure.core/keyword?), :val ("s") :via []}] 105 | 106 | star nil [] nil 107 | star [] [] nil 108 | star [:k] [:k] nil 109 | star [:k1 :k2] [:k1 :k2] nil 110 | star [:k1 :k2 "x"] ::s/invalid '[{:pred clojure.core/keyword?, :val "x" :via []}] 111 | star ["a"] ::s/invalid '[{:pred clojure.core/keyword?, :val "a" :via []}] 112 | 113 | plus nil ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/keyword?, :val () :via []}] 114 | plus [] ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/keyword?, :val () :via []}] 115 | plus [:k] [:k] nil 116 | plus [:k1 :k2] [:k1 :k2] nil 117 | plus [:k1 :k2 "x"] ::s/invalid '[{:pred clojure.core/keyword?, :val "x", :in [2]}] 118 | plus ["a"] ::s/invalid '[{:pred clojure.core/keyword?, :val "a" :via []}] 119 | 120 | opt nil nil nil 121 | opt [] nil nil 122 | opt :k ::s/invalid '[{:pred (clojure.core/fn [%] (clojure.core/or (clojure.core/nil? %) (clojure.core/sequential? %))), :val :k}] 123 | opt [:k] :k nil 124 | opt [:k1 :k2] ::s/invalid '[{:reason "Extra input", :pred (clojure.spec.alpha/? clojure.core/keyword?), :val (:k2)}] 125 | opt [:k1 :k2 "x"] ::s/invalid '[{:reason "Extra input", :pred (clojure.spec.alpha/? clojure.core/keyword?), :val (:k2 "x")}] 126 | opt ["a"] ::s/invalid '[{:pred clojure.core/keyword?, :val "a"}] 127 | 128 | andre nil nil nil 129 | andre [] nil nil 130 | andre :k :clojure.spec.alpha/invalid '[{:pred (clojure.core/fn [%] (clojure.core/or (clojure.core/nil? %) (clojure.core/sequential? %))), :val :k}] 131 | andre [:k] ::s/invalid '[{:pred clojure.test-clojure.spec-test/even-count?, :val [:k]}] ;;; renamed to match new namespace 132 | andre [:j :k] [:j :k] nil 133 | 134 | andre2 nil :clojure.spec.alpha/invalid [{:pred #{[:a]}, :val []}] 135 | andre2 [] :clojure.spec.alpha/invalid [{:pred #{[:a]}, :val []}] 136 | andre2 [:a] [:a] nil 137 | 138 | m nil ::s/invalid '[{:pred clojure.core/map?, :val nil}] 139 | m {} {} nil 140 | m {:a "b"} {:a "b"} nil 141 | 142 | mkeys nil ::s/invalid '[{:pred clojure.core/map?, :val nil}] 143 | mkeys {} {} nil 144 | mkeys {:a 1 :b 2} {:a 1 :b 2} nil 145 | 146 | mkeys2 nil ::s/invalid '[{:pred clojure.core/map?, :val nil}] 147 | mkeys2 {} {} nil 148 | mkeys2 {:a 1 :b 2} {"a" 1 "b" 2} nil 149 | 150 | s '([:a 1] [:b "2"]) '({:tag :a :val 1} {:tag :b :val "2"}) nil 151 | 152 | v [:a :b] [:a :b] nil 153 | v '(:a :b) ::s/invalid '[{:pred clojure.core/vector? :val (:a :b)}] 154 | 155 | coll nil ::s/invalid '[{:path [], :pred clojure.core/coll?, :val nil, :via [], :in []}] 156 | coll [] [] nil 157 | coll [:a] [:a] nil 158 | coll [:a :b] [:a :b] nil 159 | coll (map identity [:a :b]) '(:a :b) nil 160 | ;;coll [:a "b"] ::s/invalid '[{:pred (coll-checker keyword?), :val [:a b]}] 161 | ))) 162 | 163 | (deftest describing-evaled-specs 164 | (let [sp #{1 2}] 165 | (is (= (s/describe sp) (s/form sp) sp))) 166 | 167 | (is (= (s/describe odd?) 'odd?)) 168 | (is (= (s/form odd?) 'clojure.core/odd?)) 169 | 170 | (is (= (s/describe #(odd? %)) ::s/unknown)) 171 | (is (= (s/form #(odd? %)) ::s/unknown))) 172 | 173 | (defn check-conform-unform [spec vals expected-conforms] 174 | (let [actual-conforms (map #(s/conform spec %) vals) 175 | unforms (map #(s/unform spec %) actual-conforms)] 176 | (is (= actual-conforms expected-conforms)) 177 | (is (= vals unforms)))) 178 | 179 | (deftest nilable-conform-unform 180 | (check-conform-unform 181 | (s/nilable int?) 182 | [5 nil] 183 | [5 nil]) 184 | (check-conform-unform 185 | (s/nilable (s/or :i int? :s string?)) 186 | [5 "x" nil] 187 | [[:i 5] [:s "x"] nil])) 188 | 189 | (deftest nonconforming-conform-unform 190 | (check-conform-unform 191 | (s/nonconforming (s/or :i int? :s string?)) 192 | [5 "x"] 193 | [5 "x"])) 194 | 195 | (deftest coll-form 196 | (are [spec form] 197 | (= (s/form spec) form) 198 | (s/map-of int? any?) 199 | '(clojure.spec.alpha/map-of clojure.core/int? clojure.core/any?) 200 | 201 | (s/coll-of int?) 202 | '(clojure.spec.alpha/coll-of clojure.core/int?) 203 | 204 | (s/every-kv int? int?) 205 | '(clojure.spec.alpha/every-kv clojure.core/int? clojure.core/int?) 206 | 207 | (s/every int?) 208 | '(clojure.spec.alpha/every clojure.core/int?) 209 | 210 | (s/coll-of (s/tuple (s/tuple int?))) 211 | '(clojure.spec.alpha/coll-of (clojure.spec.alpha/tuple (clojure.spec.alpha/tuple clojure.core/int?))) 212 | 213 | (s/coll-of int? :kind vector?) 214 | '(clojure.spec.alpha/coll-of clojure.core/int? :kind clojure.core/vector?) 215 | 216 | (s/coll-of int? :gen #(gen/return [1 2])) 217 | '(clojure.spec.alpha/coll-of clojure.core/int? :gen (fn* [] (gen/return [1 2]))))) 218 | 219 | (deftest coll-conform-unform 220 | (check-conform-unform 221 | (s/coll-of (s/or :i int? :s string?)) 222 | [[1 "x"]] 223 | [[[:i 1] [:s "x"]]]) 224 | (check-conform-unform 225 | (s/every (s/or :i int? :s string?)) 226 | [[1 "x"]] 227 | [[1 "x"]]) 228 | (check-conform-unform 229 | (s/map-of int? (s/or :i int? :s string?)) 230 | [{10 10 20 "x"}] 231 | [{10 [:i 10] 20 [:s "x"]}]) 232 | (check-conform-unform 233 | (s/map-of (s/or :i int? :s string?) int? :conform-keys true) 234 | [{10 10 "x" 20}] 235 | [{[:i 10] 10 [:s "x"] 20}]) 236 | (check-conform-unform 237 | (s/every-kv int? (s/or :i int? :s string?)) 238 | [{10 10 20 "x"}] 239 | [{10 10 20 "x"}])) 240 | 241 | (deftest &-explain-pred 242 | (are [val expected] 243 | (= expected (-> (s/explain-data (s/& int? even?) val) ::s/problems first :pred)) 244 | [] 'clojure.core/int? 245 | [0 2] '(clojure.spec.alpha/& clojure.core/int? clojure.core/even?))) 246 | 247 | (deftest keys-explain-pred 248 | (is (= 'clojure.core/map? (-> (s/explain-data (s/keys :req [::x]) :a) ::s/problems first :pred)))) 249 | 250 | (deftest remove-def 251 | (is (= ::ABC (s/def ::ABC string?))) 252 | (is (= ::ABC (s/def ::ABC nil))) 253 | (is (nil? (s/get-spec ::ABC)))) 254 | 255 | ;;; CRAP added to get around lazy loading stupidity that I can't figure out. Need to call it twice!!!! TODO: Someday figure out why this is such a failure 256 | ;;; Someday -- I've partially tracked this down. in gen/spec-for-pred, there is a lookup in a map of basic predicates, keyed on the function, such as nat-int?. 257 | ;;; It appears that at some point in the loading, the values of nat-int?, string?, etc. change and the lookup no longer works. 258 | ;;; For some reason, this trick seems to solve it. I have no idea why. Still need to track it down. 259 | (defn stupidity [] 260 | (s/def ::q nat-int?) 261 | (try (s/exercise (s/keys :req [::q])) (catch Exception e nil))) 262 | 263 | (stupidity) 264 | (stupidity) 265 | 266 | ;; TODO replace this with a generative test once we have specs for s/keys 267 | (deftest map-spec-generators 268 | (s/def ::a nat-int?) 269 | (s/def ::b boolean?) 270 | (s/def ::c keyword?) 271 | (s/def ::d double?) 272 | (s/def ::e inst?) 273 | 274 | (is (= #{[::a] 275 | [::a ::b] 276 | [::a ::b ::c] 277 | [::a ::c]} 278 | (->> (s/exercise (s/keys :req [::a] :opt [::b ::c]) 100) 279 | (map (comp sort keys first)) 280 | (into #{})))) 281 | 282 | (is (= #{[:a] 283 | [:a :b] 284 | [:a :b :c] 285 | [:a :c]} 286 | (->> (s/exercise (s/keys :req-un [::a] :opt-un [::b ::c]) 100) 287 | (map (comp sort keys first)) 288 | (into #{})))) 289 | 290 | (is (= #{[::a ::b] 291 | [::a ::b ::c ::d] 292 | [::a ::b ::c ::d ::e] 293 | [::a ::b ::c ::e] 294 | [::a ::c ::d] 295 | [::a ::c ::d ::e] 296 | [::a ::c ::e]} 297 | (->> (s/exercise (s/keys :req [::a (or ::b (and ::c (or ::d ::e)))]) 200) 298 | (map (comp vec sort keys first)) 299 | (into #{})))) 300 | 301 | (is (= #{[:a :b] 302 | [:a :b :c :d] 303 | [:a :b :c :d :e] 304 | [:a :b :c :e] 305 | [:a :c :d] 306 | [:a :c :d :e] 307 | [:a :c :e]} 308 | (->> (s/exercise (s/keys :req-un [::a (or ::b (and ::c (or ::d ::e)))]) 200) 309 | (map (comp vec sort keys first)) 310 | (into #{}))))) 311 | 312 | (deftest tuple-explain-pred 313 | (are [val expected] 314 | (= expected (-> (s/explain-data (s/tuple int?) val) ::s/problems first :pred)) 315 | :a 'clojure.core/vector? 316 | [] '(clojure.core/= (clojure.core/count %) 1))) 317 | 318 | (comment 319 | (require '[clojure.test :refer (run-tests)]) 320 | (in-ns 'clojure.test-clojure.spec-test) ;;; ;;; renamed as spec-test for test-runner compat 321 | (run-tests) 322 | 323 | ) -------------------------------------------------------------------------------- /src/main/clojure/clojure/spec/test/alpha.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey. All rights reserved. 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.spec.test.alpha 10 | (:refer-clojure :exclude [test]) 11 | (:require 12 | [clojure.pprint :as pp] 13 | [clojure.spec.alpha :as s] 14 | [clojure.spec.gen.alpha :as gen] 15 | [clojure.string :as str])) 16 | 17 | (in-ns 'clojure.spec.test.check) 18 | (in-ns 'clojure.spec.test.alpha) 19 | (alias 'stc 'clojure.spec.test.check) 20 | 21 | (defn- throwable? 22 | [x] 23 | (instance? Exception x)) ;;; Throwable 24 | 25 | (defn ->sym 26 | [x] 27 | (@#'s/->sym x)) 28 | 29 | (defn- ->var 30 | [s-or-v] 31 | (if (var? s-or-v) 32 | s-or-v 33 | (let [v (and (symbol? s-or-v) (resolve s-or-v))] 34 | (if (var? v) 35 | v 36 | (throw (ArgumentException. (str (pr-str s-or-v) " does not name a var"))))))) ;;; IllegalArgumentException. 37 | 38 | (defn- collectionize 39 | [x] 40 | (if (symbol? x) 41 | (list x) 42 | x)) 43 | 44 | (defn enumerate-namespace 45 | "Given a symbol naming an ns, or a collection of such symbols, 46 | returns the set of all symbols naming vars in those nses." 47 | [ns-sym-or-syms] 48 | (into 49 | #{} 50 | (mapcat (fn [ns-sym] 51 | (map 52 | (fn [name-sym] 53 | (symbol (name ns-sym) (name name-sym))) 54 | (keys (ns-interns ns-sym))))) 55 | (collectionize ns-sym-or-syms))) 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; instrument ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | 59 | (def ^:private ^:dynamic *instrument-enabled* 60 | "if false, instrumented fns call straight through" 61 | true) 62 | 63 | (defn- fn-spec? 64 | "Fn-spec must include at least :args or :ret specs." 65 | [m] 66 | (or (:args m) (:ret m))) 67 | 68 | (defmacro with-instrument-disabled 69 | "Disables instrument's checking of calls, within a scope." 70 | [& body] 71 | `(binding [*instrument-enabled* nil] 72 | ~@body)) 73 | 74 | (defn- thunk-frame? [s] 75 | (str/includes? s "--KVS--EMULATION--THUNK--")) 76 | 77 | (defn- interpret-stack-trace-element 78 | "Given the vector-of-syms form of a stacktrace element produced 79 | by e.g. Throwable->map, returns a map form that adds some keys 80 | guessing the original Clojure names. Returns a map with 81 | 82 | :class class name symbol from stack trace 83 | :method method symbol from stack trace 84 | :file filename from stack trace 85 | :line line number from stack trace 86 | :var-scope optional Clojure var symbol scoping fn def 87 | :local-fn optional local Clojure symbol scoping fn def 88 | 89 | For non-Clojure fns, :scope and :local-fn will be absent." 90 | [[cls method file line]] 91 | (let [clojure? (contains? '#{invoke invokeStatic} method) 92 | demunge #(clojure.lang.Compiler/demunge %) 93 | degensym #(str/replace % #"--.*" "") 94 | [ns-sym name-sym local] (when clojure? 95 | (->> (str/split (str cls) #"\$" 3) 96 | (map demunge)))] 97 | (merge {:file file 98 | :line line 99 | :method method 100 | :class cls} 101 | (when (and ns-sym name-sym) 102 | {:var-scope (symbol ns-sym name-sym)}) 103 | (when local 104 | {:local-fn (symbol (degensym local)) 105 | :thunk? (thunk-frame? local)})))) 106 | 107 | (defn- stacktrace-relevant-to-instrument 108 | "Takes a coll of stack trace elements (as returned by 109 | StackTraceElement->vec) and returns a coll of maps as per 110 | interpret-stack-trace-element that are relevant to a 111 | failure in instrument." 112 | [elems] 113 | (let [plumbing? (fn [{:keys [var-scope thunk?]}] 114 | (or thunk? 115 | (contains? '#{clojure.spec.test.alpha/spec-checking-fn 116 | clojure.core/apply} 117 | var-scope)))] 118 | (sequence (comp (map StackTraceElement->vec) 119 | (map interpret-stack-trace-element) 120 | (filter :var-scope) 121 | (drop-while plumbing?)) 122 | elems))) 123 | 124 | (defn- spec-checking-fn 125 | "Takes a function name, a function f, and an fspec and returns a thunk that 126 | first conforms the arguments given then calls f with those arguments if 127 | the conform succeeds. Otherwise, an exception is thrown containing information 128 | about the conform failure." 129 | [fn-name f fn-spec] 130 | (let [fn-spec (@#'s/maybe-spec fn-spec) 131 | conform! (fn [fn-name role spec data args] 132 | (let [conformed (s/conform spec data)] 133 | (if (= ::s/invalid conformed) 134 | (let [caller (->> (.GetFrames (System.Diagnostics.StackTrace. true)) ;;; (.getStackTrace (Thread/currentThread)) 135 | stacktrace-relevant-to-instrument 136 | first) 137 | ed (merge (assoc (s/explain-data* spec [] [] [] data) 138 | ::s/fn fn-name 139 | ::s/args args 140 | ::s/failure :instrument) 141 | (when caller 142 | {::caller (dissoc caller :class :method)}))] 143 | (throw (ex-info 144 | (str "Call to " fn-name " did not conform to spec.") 145 | ed))) 146 | conformed)))] 147 | (fn 148 | [& args] 149 | (if *instrument-enabled* 150 | (with-instrument-disabled 151 | (when (:args fn-spec) (conform! fn-name :args (:args fn-spec) args args)) 152 | (binding [*instrument-enabled* true] 153 | (.applyTo ^clojure.lang.IFn f args))) 154 | (.applyTo ^clojure.lang.IFn f args))))) 155 | 156 | (defn- no-fspec 157 | [v spec] 158 | (ex-info (str "Fn at " v " is not spec'ed.") 159 | {:var v :spec spec ::s/failure :no-fspec})) 160 | 161 | (defonce ^:private instrumented-vars (atom {})) 162 | 163 | (defn- find-varargs-decl 164 | "Takes an arglist and returns the restargs binding form if found, else nil." 165 | [arglist] 166 | (let [[_ decl :as restargs] (->> arglist 167 | (split-with (complement #{'&})) 168 | second)] 169 | (and (= 2 (count restargs)) 170 | decl))) 171 | 172 | (defn- has-kwargs? [arglists] 173 | (->> arglists (some find-varargs-decl) map?)) 174 | 175 | (defn- kwargs->kvs 176 | "Takes the restargs of a kwargs function call and checks for a trailing element. 177 | If found, that element is flattened into a sequence of key->value pairs and 178 | concatenated onto the preceding arguments." 179 | [args] 180 | (if (even? (count args)) 181 | args 182 | (concat (butlast args) 183 | (reduce-kv (fn [acc k v] (->> acc (cons v) (cons k))) 184 | () 185 | (last args))))) 186 | 187 | (defn- gen-fixed-args-syms 188 | "Takes an arglist and generates a vector of names corresponding to the fixed 189 | args found." 190 | [arglist] 191 | (->> arglist (take-while (complement #{'&})) (map (fn [_] (gensym))) vec)) 192 | 193 | (defn- build-kwargs-body 194 | "Takes a function name fn-name and arglist and returns code for a function body that 195 | handles kwargs by calling fn-name with any fixed followed by its restargs transformed 196 | from kwargs to kvs." 197 | [fn-name arglist] 198 | (let [alias (gensym "kwargs") 199 | head-args (gen-fixed-args-syms arglist)] 200 | (list (conj head-args '& alias) 201 | `(apply ~fn-name ~@head-args (@#'kwargs->kvs ~alias))))) 202 | 203 | (defn- build-varargs-body 204 | "Takes a function name fn-name and arglist and returns code for a function body that 205 | handles varargs by calling fn-name with any fixed args followed by its rest args." 206 | [fn-name arglist] 207 | (let [head-args (gen-fixed-args-syms arglist) 208 | alias (gensym "restargs")] 209 | (list (conj head-args '& alias) 210 | `(apply ~fn-name ~@head-args ~alias)))) 211 | 212 | (defn- build-fixed-args-body 213 | "Takes a function name fn-name and arglist and returns code for a function body that 214 | handles fixed args by calling fn-name with its fixed args." 215 | [fn-name arglist] 216 | (let [arglist (gen-fixed-args-syms arglist)] 217 | (list arglist 218 | `(~fn-name ~@arglist)))) 219 | 220 | (defn- build-flattener-code 221 | "Takes argslists and generates code for a HOF that given a function, returns a forwarding thunk 222 | of analogous arglists that ensures that kwargs are passed as kvs to the original function." 223 | [arglists] 224 | (let [closed-over-name (gensym "inner")] 225 | `(fn [~closed-over-name] 226 | (fn ~'--KVS--EMULATION--THUNK-- 227 | ~@(map (fn [arglist] 228 | (let [varargs-decl (find-varargs-decl arglist)] 229 | (cond (map? varargs-decl) (build-kwargs-body closed-over-name arglist) 230 | varargs-decl (build-varargs-body closed-over-name arglist) 231 | :default (build-fixed-args-body closed-over-name arglist)))) 232 | (or arglists 233 | '([& args]))))))) 234 | 235 | (comment 236 | ;; Given a function with the arglists (([a]) ([a b]) ([a b & kvs])) 237 | ;; the flattener generated is below (with some gensym name cleanup for readability) 238 | (fn [inner] 239 | (fn 240 | ([G__a] (inner G__a)) 241 | ([G__a G__b] (inner G__a G__b)) 242 | ([G__a G__b & G__kvs] 243 | (apply inner G__a G__b (if (even? (count G__kvs)) 244 | G__kvs 245 | (reduce-kv (fn [acc k v] 246 | (->> acc (cons v) (cons k))) 247 | (butlast G__kvs) 248 | (last G__kvs))))))) 249 | ) 250 | 251 | (defn- maybe-wrap-kvs-emulation 252 | "Takes an argslist and function f and returns f except when arglists 253 | contains a kwargs binding, else wraps f with a forwarding thunk that 254 | flattens a trailing map into kvs if present in the kwargs call." 255 | [f arglists] 256 | (if (has-kwargs? arglists) 257 | (let [flattener-code (build-flattener-code arglists) 258 | kvs-emu (eval flattener-code)] 259 | (kvs-emu f)) 260 | f)) 261 | 262 | (defn- instrument-choose-fn 263 | "Helper for instrument." 264 | [f spec sym {over :gen :keys [stub replace]}] 265 | (if (some #{sym} stub) 266 | (-> spec (s/gen over) gen/generate) 267 | (get replace sym f))) 268 | 269 | (defn- instrument-choose-spec 270 | "Helper for instrument" 271 | [spec sym {overrides :spec}] 272 | (get overrides sym spec)) 273 | 274 | (defn- instrument-1 275 | [s opts] 276 | (when-let [v (resolve s)] 277 | (when-not (-> v meta :macro) 278 | (let [spec (s/get-spec v) 279 | {:keys [raw wrapped]} (get @instrumented-vars v) 280 | current @v 281 | to-wrap (if (= wrapped current) raw current) 282 | ospec (or (instrument-choose-spec spec s opts) 283 | (throw (no-fspec v spec))) 284 | ofn (instrument-choose-fn to-wrap ospec s opts) 285 | checked (spec-checking-fn (->sym v) ofn ospec) 286 | arglists (->> v meta :arglists (sort-by count) seq) 287 | wrapped (maybe-wrap-kvs-emulation checked arglists)] 288 | (alter-var-root v (constantly wrapped)) 289 | (swap! instrumented-vars assoc v {:raw to-wrap :wrapped wrapped}) 290 | (->sym v))))) 291 | 292 | (defn- unstrument-1 293 | [s] 294 | (when-let [v (resolve s)] 295 | (when-let [{:keys [raw wrapped]} (get @instrumented-vars v)] 296 | (swap! instrumented-vars dissoc v) 297 | (let [current @v] 298 | (when (= wrapped current) 299 | (alter-var-root v (constantly raw)) 300 | (->sym v)))))) 301 | 302 | (defn- opt-syms 303 | "Returns set of symbols referenced by 'instrument' opts map" 304 | [opts] 305 | (reduce into #{} [(:stub opts) (keys (:replace opts)) (keys (:spec opts))])) 306 | 307 | (defn- fn-spec-name? 308 | [s] 309 | (and (symbol? s) 310 | (not (some-> (resolve s) meta :macro)))) 311 | 312 | (defn instrumentable-syms 313 | "Given an opts map as per instrument, returns the set of syms 314 | that can be instrumented." 315 | ([] (instrumentable-syms nil)) 316 | ([opts] 317 | (assert (every? ident? (keys (:gen opts))) "instrument :gen expects ident keys") 318 | (reduce into #{} [(filter fn-spec-name? (keys (s/registry))) 319 | (keys (:spec opts)) 320 | (:stub opts) 321 | (keys (:replace opts))]))) 322 | 323 | (defn instrument 324 | "Instruments the vars named by sym-or-syms, a symbol or collection 325 | of symbols, or all instrumentable vars if sym-or-syms is not 326 | specified. 327 | 328 | If a var has an :args fn-spec, sets the var's root binding to a 329 | fn that checks arg conformance (throwing an exception on failure) 330 | before delegating to the original fn. 331 | 332 | The opts map can be used to override registered specs, and/or to 333 | replace fn implementations entirely. Opts for symbols not included 334 | in sym-or-syms are ignored. This facilitates sharing a common 335 | options map across many different calls to instrument. 336 | 337 | The opts map may have the following keys: 338 | 339 | :spec a map from var-name symbols to override specs 340 | :stub a set of var-name symbols to be replaced by stubs 341 | :gen a map from spec names to generator overrides 342 | :replace a map from var-name symbols to replacement fns 343 | 344 | :spec overrides registered fn-specs with specs your provide. Use 345 | :spec overrides to provide specs for libraries that do not have 346 | them, or to constrain your own use of a fn to a subset of its 347 | spec'ed contract. 348 | 349 | :stub replaces a fn with a stub that checks :args, then uses the 350 | :ret spec to generate a return value. 351 | 352 | :gen overrides are used only for :stub generation. 353 | 354 | :replace replaces a fn with a fn that checks args conformance, then 355 | invokes the fn you provide, enabling arbitrary stubbing and mocking. 356 | 357 | :spec can be used in combination with :stub or :replace. 358 | 359 | Returns a collection of syms naming the vars instrumented." 360 | ([] (instrument (instrumentable-syms))) 361 | ([sym-or-syms] (instrument sym-or-syms nil)) 362 | ([sym-or-syms opts] 363 | (locking instrumented-vars 364 | (into 365 | [] 366 | (comp (filter (instrumentable-syms opts)) 367 | (distinct) 368 | (map #(instrument-1 % opts)) 369 | (remove nil?)) 370 | (collectionize sym-or-syms))))) 371 | 372 | (defn unstrument 373 | "Undoes instrument on the vars named by sym-or-syms, specified 374 | as in instrument. With no args, unstruments all instrumented vars. 375 | Returns a collection of syms naming the vars unstrumented." 376 | ([] (unstrument (map ->sym (keys @instrumented-vars)))) 377 | ([sym-or-syms] 378 | (locking instrumented-vars 379 | (into 380 | [] 381 | (comp (filter symbol?) 382 | (map unstrument-1) 383 | (remove nil?)) 384 | (collectionize sym-or-syms))))) 385 | 386 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; testing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 387 | 388 | (defn- explain-check 389 | [args spec v role] 390 | (ex-info 391 | "Specification-based check failed" 392 | (when-not (s/valid? spec v nil) 393 | (assoc (s/explain-data* spec [role] [] [] v) 394 | ::args args 395 | ::val v 396 | ::s/failure :check-failed)))) 397 | 398 | (defn- check-call 399 | "Returns true if call passes specs, otherwise *returns* an exception 400 | with explain-data + ::s/failure." 401 | [f specs args] 402 | (let [cargs (when (:args specs) (s/conform (:args specs) args))] 403 | (if (= cargs ::s/invalid) 404 | (explain-check args (:args specs) args :args) 405 | (let [ret (apply f args) 406 | cret (when (:ret specs) (s/conform (:ret specs) ret))] 407 | (if (= cret ::s/invalid) 408 | (explain-check args (:ret specs) ret :ret) 409 | (if (and (:args specs) (:ret specs) (:fn specs)) 410 | (if (s/valid? (:fn specs) {:args cargs :ret cret}) 411 | true 412 | (explain-check args (:fn specs) {:args cargs :ret cret} :fn)) 413 | true)))))) 414 | 415 | (defn- quick-check 416 | [f specs {gen :gen opts ::stc/opts}] 417 | (let [{:keys [num-tests] :or {num-tests 1000}} opts 418 | g (try (s/gen (:args specs) gen) (catch Exception t t))] ;;; Throwable 419 | (if (throwable? g) 420 | {:result g} 421 | (let [prop (gen/for-all* [g] #(check-call f specs %))] 422 | (apply gen/quick-check num-tests prop (mapcat identity opts)))))) 423 | 424 | (defn- make-check-result 425 | "Builds spec result map." 426 | [check-sym spec test-check-ret] 427 | (merge {:spec spec 428 | ::stc/ret test-check-ret} 429 | (when check-sym 430 | {:sym check-sym}) 431 | (when-let [result (-> test-check-ret :result)] 432 | (when-not (true? result) {:failure result})) 433 | (when-let [shrunk (-> test-check-ret :shrunk)] 434 | {:failure (:result shrunk)}))) 435 | 436 | (defn- check-1 437 | [{:keys [s f v spec]} opts] 438 | (let [re-inst? (and v (seq (unstrument s)) true) 439 | f (or f (when v @v)) 440 | specd (s/spec spec)] 441 | (try 442 | (cond 443 | (or (nil? f) (some-> v meta :macro)) 444 | {:failure (ex-info "No fn to spec" {::s/failure :no-fn}) 445 | :sym s :spec spec} 446 | 447 | (:args specd) 448 | (let [tcret (quick-check f specd opts)] 449 | (make-check-result s spec tcret)) 450 | 451 | :default 452 | {:failure (ex-info "No :args spec" {::s/failure :no-args-spec}) 453 | :sym s :spec spec}) 454 | (finally 455 | (when re-inst? (instrument s)))))) 456 | 457 | (defn- sym->check-map 458 | [s] 459 | (let [v (resolve s)] 460 | {:s s 461 | :v v 462 | :spec (when v (s/get-spec v))})) 463 | 464 | (defn- validate-check-opts 465 | [opts] 466 | (assert (every? ident? (keys (:gen opts))) "check :gen expects ident keys")) 467 | 468 | (defn check-fn 469 | "Runs generative tests for fn f using spec and opts. See 470 | 'check' for options and return." 471 | ([f spec] (check-fn f spec nil)) 472 | ([f spec opts] 473 | (validate-check-opts opts) 474 | (check-1 {:f f :spec spec} opts))) 475 | 476 | (defn checkable-syms 477 | "Given an opts map as per check, returns the set of syms that 478 | can be checked." 479 | ([] (checkable-syms nil)) 480 | ([opts] 481 | (validate-check-opts opts) 482 | (reduce into #{} [(filter fn-spec-name? (keys (s/registry))) 483 | (keys (:spec opts))]))) 484 | 485 | (defn check 486 | "Run generative tests for spec conformance on vars named by 487 | sym-or-syms, a symbol or collection of symbols. If sym-or-syms 488 | is not specified, check all checkable vars. 489 | 490 | The opts map includes the following optional keys, where stc 491 | aliases clojure.spec.test.check: 492 | 493 | ::stc/opts opts to flow through test.check/quick-check 494 | :gen map from spec names to generator overrides 495 | 496 | The ::stc/opts include :num-tests in addition to the keys 497 | documented by test.check. Generator overrides are passed to 498 | spec/gen when generating function args. 499 | 500 | Returns a lazy sequence of check result maps with the following 501 | keys 502 | 503 | :spec the spec tested 504 | :sym optional symbol naming the var tested 505 | :failure optional test failure 506 | ::stc/ret optional value returned by test.check/quick-check 507 | 508 | The value for :failure can be any exception. Exceptions thrown by 509 | spec itself will have an ::s/failure value in ex-data: 510 | 511 | :check-failed at least one checked return did not conform 512 | :no-args-spec no :args spec provided 513 | :no-fn no fn provided 514 | :no-fspec no fspec provided 515 | :no-gen unable to generate :args 516 | :instrument invalid args detected by instrument 517 | " 518 | ([] (check (checkable-syms))) 519 | ([sym-or-syms] (check sym-or-syms nil)) 520 | ([sym-or-syms opts] 521 | (->> (collectionize sym-or-syms) 522 | (filter (checkable-syms opts)) 523 | (pmap 524 | #(check-1 (sym->check-map %) opts))))) 525 | 526 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; check reporting ;;;;;;;;;;;;;;;;;;;;;;;; 527 | 528 | (defn- failure-type 529 | [x] 530 | (::s/failure (ex-data x))) 531 | 532 | (defn- unwrap-failure 533 | [x] 534 | (if (failure-type x) 535 | (ex-data x) 536 | x)) 537 | 538 | (defn- result-type 539 | "Returns the type of the check result. This can be any of the 540 | ::s/failure keywords documented in 'check', or: 541 | 542 | :check-passed all checked fn returns conformed 543 | :check-threw checked fn threw an exception" 544 | [ret] 545 | (let [failure (:failure ret)] 546 | (cond 547 | (nil? failure) :check-passed 548 | (failure-type failure) (failure-type failure) 549 | :default :check-threw))) 550 | 551 | (defn abbrev-result 552 | "Given a check result, returns an abbreviated version 553 | suitable for summary use." 554 | [x] 555 | (if (:failure x) 556 | (-> (dissoc x ::stc/ret) 557 | (update :spec s/describe) 558 | (update :failure unwrap-failure)) 559 | (dissoc x :spec ::stc/ret))) 560 | 561 | (defn summarize-results 562 | "Given a collection of check-results, e.g. from 'check', pretty 563 | prints the summary-result (default abbrev-result) of each. 564 | 565 | Returns a map with :total, the total number of results, plus a 566 | key with a count for each different :type of result." 567 | ([check-results] (summarize-results check-results abbrev-result)) 568 | ([check-results summary-result] 569 | (reduce 570 | (fn [summary result] 571 | (pp/pprint (summary-result result)) 572 | (-> summary 573 | (update :total inc) 574 | (update (result-type result) (fnil inc 0)))) 575 | {:total 0} 576 | check-results))) 577 | 578 | 579 | -------------------------------------------------------------------------------- /src/main/clojure/clojure/spec/alpha.clj: -------------------------------------------------------------------------------- 1 | ; Copyright (c) Rich Hickey. All rights reserved. 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 "The spec library specifies the structure of data or functions and provides 11 | operations to validate, conform, explain, describe, and generate data based on 12 | the specs. 13 | 14 | Rationale: https://clojure.org/about/spec 15 | Guide: https://clojure.org/guides/spec"} 16 | clojure.spec.alpha 17 | (:refer-clojure :exclude [+ * and assert or cat def keys merge]) 18 | (:require [clojure.walk :as walk] 19 | [clojure.spec.gen.alpha :as gen] 20 | [clojure.string :as str])) 21 | 22 | (alias 'c 'clojure.core) 23 | 24 | (set! *warn-on-reflection* true) 25 | 26 | (def ^:dynamic *recursion-limit* 27 | "A soft limit on how many times a branching spec (or/alt/*/opt-keys/multi-spec) 28 | can be recursed through during generation. After this a 29 | non-recursive branch will be chosen." 30 | 4) 31 | 32 | (def ^:dynamic *fspec-iterations* 33 | "The number of times an anonymous fn specified by fspec will be (generatively) tested during conform" 34 | 21) 35 | 36 | (def ^:dynamic *coll-check-limit* 37 | "The number of elements validated in a collection spec'ed with 'every'" 38 | 101) 39 | 40 | (def ^:dynamic *coll-error-limit* 41 | "The number of errors reported by explain in a collection spec'ed with 'every'" 42 | 20) 43 | 44 | (defprotocol Spec 45 | (conform* [spec x]) 46 | (unform* [spec y]) 47 | (explain* [spec path via in x]) 48 | (gen* [spec overrides path rmap]) 49 | (with-gen* [spec gfn]) 50 | (describe* [spec])) 51 | 52 | (defonce ^:private registry-ref (atom {})) 53 | 54 | (defn- deep-resolve [reg k] 55 | (loop [spec k] 56 | (if (ident? spec) 57 | (recur (get reg spec)) 58 | spec))) 59 | 60 | (defn- reg-resolve 61 | "returns the spec/regex at end of alias chain starting with k, nil if not found, k if k not ident" 62 | [k] 63 | (if (ident? k) 64 | (let [reg @registry-ref 65 | spec (get reg k)] 66 | (if-not (ident? spec) 67 | spec 68 | (deep-resolve reg spec))) 69 | k)) 70 | 71 | (defn- reg-resolve! 72 | "returns the spec/regex at end of alias chain starting with k, throws if not found, k if k not ident" 73 | [k] 74 | (if (ident? k) 75 | (c/or (reg-resolve k) 76 | (throw (Exception. (str "Unable to resolve spec: " k)))) 77 | k)) 78 | 79 | (defn spec? 80 | "returns x if x is a spec object, else logical false" 81 | [x] 82 | (when (instance? clojure.spec.alpha.Spec x) 83 | x)) 84 | 85 | (defn regex? 86 | "returns x if x is a (clojure.spec) regex op, else logical false" 87 | [x] 88 | (c/and (::op x) x)) 89 | 90 | (defn- with-name [spec name] 91 | (cond 92 | (ident? spec) spec 93 | (regex? spec) (assoc spec ::name name) 94 | 95 | (instance? clojure.lang.IObj spec) 96 | (with-meta spec (assoc (meta spec) ::name name)))) 97 | 98 | (defn- spec-name [spec] 99 | (cond 100 | (ident? spec) spec 101 | 102 | (regex? spec) (::name spec) 103 | 104 | (instance? clojure.lang.IObj spec) 105 | (-> (meta spec) ::name))) 106 | 107 | (declare spec-impl) 108 | (declare regex-spec-impl) 109 | 110 | (defn- maybe-spec 111 | "spec-or-k must be a spec, regex or resolvable kw/sym, else returns nil." 112 | [spec-or-k] 113 | (let [s (c/or (c/and (ident? spec-or-k) (reg-resolve spec-or-k)) 114 | (spec? spec-or-k) 115 | (regex? spec-or-k) 116 | nil)] 117 | (if (regex? s) 118 | (with-name (regex-spec-impl s nil) (spec-name s)) 119 | s))) 120 | 121 | (defn- the-spec 122 | "spec-or-k must be a spec, regex or kw/sym, else returns nil. Throws if unresolvable kw/sym" 123 | [spec-or-k] 124 | (c/or (maybe-spec spec-or-k) 125 | (when (ident? spec-or-k) 126 | (throw (Exception. (str "Unable to resolve spec: " spec-or-k)))))) 127 | 128 | (defprotocol Specize 129 | (specize* [_] [_ form])) 130 | 131 | (defn- fn-sym [^Object f] ;;; Had to seriously hack this to handle things like user$eval_2030fn_2131_2132 132 | (let [[_ f-ns f-n] (re-matches #"(.*)\$(.*?)(__[0-9]+)?" (.. f GetType FullName))] ;;; getClass getName 133 | ;; check for anonymous function 134 | (when (not (re-matches #"(.*)\$(.*)fn(__[0-9]+)+$" (.. f GetType FullName))) ;;; (not= "fn" f-n) 135 | (symbol (clojure.lang.Compiler/demunge f-ns) (clojure.lang.Compiler/demunge f-n))))) 136 | 137 | (extend-protocol Specize 138 | clojure.lang.Keyword 139 | (specize* ([k] (specize* (reg-resolve! k))) 140 | ([k _] (specize* (reg-resolve! k)))) 141 | 142 | clojure.lang.Symbol 143 | (specize* ([s] (specize* (reg-resolve! s))) 144 | ([s _] (specize* (reg-resolve! s)))) 145 | 146 | clojure.lang.IPersistentSet 147 | (specize* ([s] (spec-impl s s nil nil)) 148 | ([s form] (spec-impl form s nil nil))) 149 | 150 | Object 151 | (specize* ([o] (if (c/and (not (map? o)) (ifn? o)) 152 | (if-let [s (fn-sym o)] 153 | (spec-impl s o nil nil) 154 | (spec-impl ::unknown o nil nil)) 155 | (spec-impl ::unknown o nil nil))) 156 | ([o form] (spec-impl form o nil nil)))) 157 | 158 | (defn- specize 159 | ([s] (c/or (spec? s) (specize* s))) 160 | ([s form] (c/or (spec? s) (specize* s form)))) 161 | 162 | (defn invalid? 163 | "tests the validity of a conform return value" 164 | [ret] 165 | (identical? ::invalid ret)) 166 | 167 | (defn conform 168 | "Given a spec and a value, returns :clojure.spec.alpha/invalid 169 | if value does not match spec, else the (possibly destructured) value." 170 | [spec x] 171 | (conform* (specize spec) x)) 172 | 173 | (defn unform 174 | "Given a spec and a value created by or compliant with a call to 175 | 'conform' with the same spec, returns a value with all conform 176 | destructuring undone." 177 | [spec x] 178 | (unform* (specize spec) x)) 179 | 180 | (defn form 181 | "returns the spec as data" 182 | [spec] 183 | ;;TODO - incorporate gens 184 | (describe* (specize spec))) 185 | 186 | (defn abbrev [form] 187 | (cond 188 | (seq? form) 189 | (walk/postwalk (fn [form] 190 | (cond 191 | (c/and (symbol? form) (namespace form)) 192 | (-> form name symbol) 193 | 194 | (c/and (seq? form) (= 'fn (first form)) (= '[%] (second form))) 195 | (last form) 196 | 197 | :else form)) 198 | form) 199 | 200 | (c/and (symbol? form) (namespace form)) 201 | (-> form name symbol) 202 | 203 | :else form)) 204 | 205 | (defn describe 206 | "returns an abbreviated description of the spec as data" 207 | [spec] 208 | (abbrev (form spec))) 209 | 210 | (defn with-gen 211 | "Takes a spec and a no-arg, generator-returning fn and returns a version of that spec that uses that generator" 212 | [spec gen-fn] 213 | (let [spec (reg-resolve spec)] 214 | (if (regex? spec) 215 | (assoc spec ::gfn gen-fn) 216 | (with-gen* (specize spec) gen-fn)))) 217 | 218 | (defn explain-data* [spec path via in x] 219 | (let [probs (explain* (specize spec) path via in x)] 220 | (when-not (empty? probs) 221 | {::problems probs 222 | ::spec spec 223 | ::value x}))) 224 | 225 | (defn explain-data 226 | "Given a spec and a value x which ought to conform, returns nil if x 227 | conforms, else a map with at least the key ::problems whose value is 228 | a collection of problem-maps, where problem-map has at least :path :pred and :val 229 | keys describing the predicate and the value that failed at that 230 | path." 231 | [spec x] 232 | (explain-data* spec [] (if-let [name (spec-name spec)] [name] []) [] x)) 233 | 234 | (defn explain-printer 235 | "Default printer for explain-data. nil indicates a successful validation." 236 | [ed] 237 | (if ed 238 | (let [problems (->> (::problems ed) 239 | (sort-by #(- (count (:in %)))) 240 | (sort-by #(- (count (:path %)))))] 241 | ;;(prn {:ed ed}) 242 | (doseq [{:keys [path pred val reason via in] :as prob} problems] 243 | (pr val) 244 | (print " - failed: ") 245 | (if reason (print reason) (pr (abbrev pred))) 246 | (when-not (empty? in) 247 | (print (str " in: " (pr-str in)))) 248 | (when-not (empty? path) 249 | (print (str " at: " (pr-str path)))) 250 | (when-not (empty? via) 251 | (print (str " spec: " (pr-str (last via))))) 252 | (doseq [[k v] prob] 253 | (when-not (#{:path :pred :val :reason :via :in} k) 254 | (print "\n\t" (pr-str k) " ") 255 | (pr v))) 256 | (newline))) 257 | (println "Success!"))) 258 | 259 | (def ^:dynamic *explain-out* explain-printer) 260 | 261 | (defn explain-out 262 | "Prints explanation data (per 'explain-data') to *out* using the printer in *explain-out*, 263 | by default explain-printer." 264 | [ed] 265 | (*explain-out* ed)) 266 | 267 | (defn explain 268 | "Given a spec and a value that fails to conform, prints an explanation to *out*." 269 | [spec x] 270 | (explain-out (explain-data spec x))) 271 | 272 | (defn explain-str 273 | "Given a spec and a value that fails to conform, returns an explanation as a string." 274 | ^String [spec x] 275 | (with-out-str (explain spec x))) 276 | 277 | (declare valid?) 278 | 279 | (defn- gensub 280 | [spec overrides path rmap form] 281 | ;;(prn {:spec spec :over overrides :path path :form form}) 282 | (let [spec (specize spec)] 283 | (if-let [g (c/or (when-let [gfn (c/or (get overrides (c/or (spec-name spec) spec)) 284 | (get overrides path))] 285 | (gfn)) 286 | (gen* spec overrides path rmap))] 287 | (gen/such-that #(valid? spec %) g 100) 288 | (let [abbr (abbrev form)] 289 | (throw (ex-info (str "Unable to construct gen at: " path " for: " abbr) 290 | {::path path ::form form ::failure :no-gen})))))) 291 | 292 | (defn gen 293 | "Given a spec, returns the generator for it, or throws if none can 294 | be constructed. Optionally an overrides map can be provided which 295 | should map spec names or paths (vectors of keywords) to no-arg 296 | generator-creating fns. These will be used instead of the generators at those 297 | names/paths. Note that parent generator (in the spec or overrides 298 | map) will supersede those of any subtrees. A generator for a regex 299 | op must always return a sequential collection (i.e. a generator for 300 | s/? should return either an empty sequence/vector or a 301 | sequence/vector with one item in it)" 302 | ([spec] (gen spec nil)) 303 | ([spec overrides] (gensub spec overrides [] {::recursion-limit *recursion-limit*} spec))) 304 | 305 | (defn- ->sym 306 | "Returns a symbol from a symbol or var" 307 | [x] 308 | (if (var? x) 309 | (symbol x) 310 | x)) 311 | 312 | (defn- unfn [expr] 313 | (if (c/and (seq? expr) 314 | (symbol? (first expr)) 315 | (= "fn*" (name (first expr)))) 316 | (let [[[s] & form] (rest expr)] 317 | (conj (walk/postwalk-replace {s '%} form) '[%] 'fn)) 318 | expr)) 319 | 320 | (defn- res [form] 321 | (cond 322 | (keyword? form) form 323 | (symbol? form) (c/or (-> form resolve ->sym) form) 324 | (sequential? form) (walk/postwalk #(if (symbol? %) (res %) %) (unfn form)) 325 | :else form)) 326 | 327 | (defn ^:skip-wiki def-impl 328 | "Do not call this directly, use 'def'" 329 | [k form spec] 330 | (c/assert (c/and (ident? k) (namespace k)) "k must be namespaced keyword or resolvable symbol") 331 | (if (nil? spec) 332 | (swap! registry-ref dissoc k) 333 | (let [spec (if (c/or (spec? spec) (regex? spec) (get @registry-ref spec)) 334 | spec 335 | (spec-impl form spec nil nil))] 336 | (swap! registry-ref assoc k (with-name spec k)))) 337 | k) 338 | 339 | (defn- ns-qualify 340 | "Qualify symbol s by resolving it or using the current *ns*." 341 | [s] 342 | (if-let [ns-sym (some-> s namespace symbol)] 343 | (c/or (some-> (get (ns-aliases *ns*) ns-sym) str (symbol (name s))) 344 | s) 345 | (symbol (str (.Name *ns*)) (str s)))) ;;; .name 346 | 347 | (defmacro def 348 | "Given a namespace-qualified keyword or resolvable symbol k, and a 349 | spec, spec-name, predicate or regex-op makes an entry in the 350 | registry mapping k to the spec. Use nil to remove an entry in 351 | the registry for k." 352 | [k spec-form] 353 | (let [k (if (symbol? k) (ns-qualify k) k)] 354 | `(def-impl '~k '~(res spec-form) ~spec-form))) 355 | 356 | (defn registry 357 | "returns the registry map, prefer 'get-spec' to lookup a spec by name" 358 | [] 359 | @registry-ref) 360 | 361 | (defn get-spec 362 | "Returns spec registered for keyword/symbol/var k, or nil." 363 | [k] 364 | (get (registry) (if (keyword? k) k (->sym k)))) 365 | 366 | (defmacro spec 367 | "Takes a single predicate form, e.g. can be the name of a predicate, 368 | like even?, or a fn literal like #(< % 42). Note that it is not 369 | generally necessary to wrap predicates in spec when using the rest 370 | of the spec macros, only to attach a unique generator 371 | 372 | Can also be passed the result of one of the regex ops - 373 | cat, alt, *, +, ?, in which case it will return a regex-conforming 374 | spec, useful when nesting an independent regex. 375 | --- 376 | 377 | Optionally takes :gen generator-fn, which must be a fn of no args that 378 | returns a test.check generator. 379 | 380 | Returns a spec." 381 | [form & {:keys [gen]}] 382 | (when form 383 | `(spec-impl '~(res form) ~form ~gen nil))) 384 | 385 | (defmacro multi-spec 386 | "Takes the name of a spec/predicate-returning multimethod and a 387 | tag-restoring keyword or fn (retag). Returns a spec that when 388 | conforming or explaining data will pass it to the multimethod to get 389 | an appropriate spec. You can e.g. use multi-spec to dynamically and 390 | extensibly associate specs with 'tagged' data (i.e. data where one 391 | of the fields indicates the shape of the rest of the structure). 392 | 393 | (defmulti mspec :tag) 394 | 395 | The methods should ignore their argument and return a predicate/spec: 396 | (defmethod mspec :int [_] (s/keys :req-un [::tag ::i])) 397 | 398 | retag is used during generation to retag generated values with 399 | matching tags. retag can either be a keyword, at which key the 400 | dispatch-tag will be assoc'ed, or a fn of generated value and 401 | dispatch-tag that should return an appropriately retagged value. 402 | 403 | Note that because the tags themselves comprise an open set, 404 | the tag key spec cannot enumerate the values, but can e.g. 405 | test for keyword?. 406 | 407 | Note also that the dispatch values of the multimethod will be 408 | included in the path, i.e. in reporting and gen overrides, even 409 | though those values are not evident in the spec. 410 | " 411 | [mm retag] 412 | `(multi-spec-impl '~(res mm) (var ~mm) ~retag)) 413 | 414 | (defmacro keys 415 | "Creates and returns a map validating spec. :req and :opt are both 416 | vectors of namespaced-qualified keywords. The validator will ensure 417 | the :req keys are present. The :opt keys serve as documentation and 418 | may be used by the generator. 419 | 420 | The :req key vector supports 'and' and 'or' for key groups: 421 | 422 | (s/keys :req [::x ::y (or ::secret (and ::user ::pwd))] :opt [::z]) 423 | 424 | There are also -un versions of :req and :opt. These allow 425 | you to connect unqualified keys to specs. In each case, fully 426 | qualified keywords are passed, which name the specs, but unqualified 427 | keys (with the same name component) are expected and checked at 428 | conform-time, and generated during gen: 429 | 430 | (s/keys :req-un [:my.ns/x :my.ns/y]) 431 | 432 | The above says keys :x and :y are required, and will be validated 433 | and generated by specs (if they exist) named :my.ns/x :my.ns/y 434 | respectively. 435 | 436 | In addition, the values of *all* namespace-qualified keys will be validated 437 | (and possibly destructured) by any registered specs. Note: there is 438 | no support for inline value specification, by design. 439 | 440 | Optionally takes :gen generator-fn, which must be a fn of no args that 441 | returns a test.check generator." 442 | [& {:keys [req req-un opt opt-un gen]}] 443 | (let [unk #(-> % name keyword) 444 | req-keys (filterv keyword? (flatten req)) 445 | req-un-specs (filterv keyword? (flatten req-un)) 446 | _ (c/assert (every? #(c/and (keyword? %) (namespace %)) (concat req-keys req-un-specs opt opt-un)) 447 | "all keys must be namespace-qualified keywords") 448 | req-specs (into req-keys req-un-specs) 449 | req-keys (into req-keys (map unk req-un-specs)) 450 | opt-keys (into (vec opt) (map unk opt-un)) 451 | opt-specs (into (vec opt) opt-un) 452 | gx (gensym) 453 | parse-req (fn [rk f] 454 | (map (fn [x] 455 | (if (keyword? x) 456 | `(contains? ~gx ~(f x)) 457 | (walk/postwalk 458 | (fn [y] (if (keyword? y) `(contains? ~gx ~(f y)) y)) 459 | x))) 460 | rk)) 461 | pred-exprs [`(map? ~gx)] 462 | pred-exprs (into pred-exprs (parse-req req identity)) 463 | pred-exprs (into pred-exprs (parse-req req-un unk)) 464 | keys-pred `(fn* [~gx] (c/and ~@pred-exprs)) 465 | pred-exprs (mapv (fn [e] `(fn* [~gx] ~e)) pred-exprs) 466 | pred-forms (walk/postwalk res pred-exprs)] 467 | ;; `(map-spec-impl ~req-keys '~req ~opt '~pred-forms ~pred-exprs ~gen) 468 | `(map-spec-impl {:req '~req :opt '~opt :req-un '~req-un :opt-un '~opt-un 469 | :req-keys '~req-keys :req-specs '~req-specs 470 | :opt-keys '~opt-keys :opt-specs '~opt-specs 471 | :pred-forms '~pred-forms 472 | :pred-exprs ~pred-exprs 473 | :keys-pred ~keys-pred 474 | :gfn ~gen}))) 475 | 476 | (defmacro or 477 | "Takes key+pred pairs, e.g. 478 | 479 | (s/or :even even? :small #(< % 42)) 480 | 481 | Returns a destructuring spec that returns a map entry containing the 482 | key of the first matching pred and the corresponding value. Thus the 483 | 'key' and 'val' functions can be used to refer generically to the 484 | components of the tagged return." 485 | [& key-pred-forms] 486 | (let [pairs (partition 2 key-pred-forms) 487 | keys (mapv first pairs) 488 | pred-forms (mapv second pairs) 489 | pf (mapv res pred-forms)] 490 | (c/assert (c/and (even? (count key-pred-forms)) (every? keyword? keys)) "spec/or expects k1 p1 k2 p2..., where ks are keywords") 491 | `(or-spec-impl ~keys '~pf ~pred-forms nil))) 492 | 493 | (defmacro and 494 | "Takes predicate/spec-forms, e.g. 495 | 496 | (s/and even? #(< % 42)) 497 | 498 | Returns a spec that returns the conformed value. Successive 499 | conformed values propagate through rest of predicates." 500 | [& pred-forms] 501 | `(and-spec-impl '~(mapv res pred-forms) ~(vec pred-forms) nil)) 502 | 503 | (defmacro merge 504 | "Takes map-validating specs (e.g. 'keys' specs) and 505 | returns a spec that returns a conformed map satisfying all of the 506 | specs. Unlike 'and', merge can generate maps satisfying the 507 | union of the predicates." 508 | [& pred-forms] 509 | `(merge-spec-impl '~(mapv res pred-forms) ~(vec pred-forms) nil)) 510 | 511 | (defn- res-kind 512 | [opts] 513 | (let [{kind :kind :as mopts} opts] 514 | (->> 515 | (if kind 516 | (assoc mopts :kind `~(res kind)) 517 | mopts) 518 | (mapcat identity)))) 519 | 520 | (defmacro every 521 | "takes a pred and validates collection elements against that pred. 522 | 523 | Note that 'every' does not do exhaustive checking, rather it samples 524 | *coll-check-limit* elements. Nor (as a result) does it do any 525 | conforming of elements. 'explain' will report at most *coll-error-limit* 526 | problems. Thus 'every' should be suitable for potentially large 527 | collections. 528 | 529 | Takes several kwargs options that further constrain the collection: 530 | 531 | :kind - a pred that the collection type must satisfy, e.g. vector? 532 | (default nil) Note that if :kind is specified and :into is 533 | not, this pred must generate in order for every to generate. 534 | :count - specifies coll has exactly this count (default nil) 535 | :min-count, :max-count - coll has count (<= min-count count max-count) (defaults nil) 536 | :distinct - all the elements are distinct (default nil) 537 | 538 | And additional args that control gen 539 | 540 | :gen-max - the maximum coll size to generate (default 20) 541 | :into - one of [], (), {}, #{} - the default collection to generate into 542 | (default: empty coll as generated by :kind pred if supplied, else []) 543 | 544 | Optionally takes :gen generator-fn, which must be a fn of no args that 545 | returns a test.check generator 546 | 547 | See also - coll-of, every-kv 548 | " 549 | [pred & {:keys [into kind count max-count min-count distinct gen-max gen] :as opts}] 550 | (let [desc (::describe opts) 551 | nopts (-> opts 552 | (dissoc :gen ::describe) 553 | (assoc ::kind-form `'~(res (:kind opts)) 554 | ::describe (c/or desc `'(every ~(res pred) ~@(res-kind opts))))) 555 | gx (gensym) 556 | cpreds (cond-> [(list (c/or kind `coll?) gx)] 557 | count (conj `(= ~count (bounded-count ~count ~gx))) 558 | 559 | (c/or min-count max-count) 560 | (conj `(<= (c/or ~min-count 0) 561 | (bounded-count (if ~max-count (inc ~max-count) ~min-count) ~gx) 562 | (c/or ~max-count Int64/MaxValue))) ;;; Integer/MAX_VALUE 563 | 564 | distinct 565 | (conj `(c/or (empty? ~gx) (apply distinct? ~gx))))] 566 | `(every-impl '~pred ~pred ~(assoc nopts ::cpred `(fn* [~gx] (c/and ~@cpreds))) ~gen))) 567 | 568 | (defmacro every-kv 569 | "like 'every' but takes separate key and val preds and works on associative collections. 570 | 571 | Same options as 'every', :into defaults to {} 572 | 573 | See also - map-of" 574 | 575 | [kpred vpred & opts] 576 | (let [desc `(every-kv ~(res kpred) ~(res vpred) ~@(res-kind opts))] 577 | `(every (tuple ~kpred ~vpred) ::kfn (fn [i# v#] (nth v# 0)) :into {} ::describe '~desc ~@opts))) 578 | 579 | (defmacro coll-of 580 | "Returns a spec for a collection of items satisfying pred. Unlike 581 | 'every', coll-of will exhaustively conform every value. 582 | 583 | Same options as 'every'. conform will produce a collection 584 | corresponding to :into if supplied, else will match the input collection, 585 | avoiding rebuilding when possible. 586 | 587 | See also - every, map-of" 588 | [pred & opts] 589 | (let [desc `(coll-of ~(res pred) ~@(res-kind opts))] 590 | `(every ~pred ::conform-all true ::describe '~desc ~@opts))) 591 | 592 | (defmacro map-of 593 | "Returns a spec for a map whose keys satisfy kpred and vals satisfy 594 | vpred. Unlike 'every-kv', map-of will exhaustively conform every 595 | value. 596 | 597 | Same options as 'every', :kind defaults to map?, with the addition of: 598 | 599 | :conform-keys - conform keys as well as values (default false) 600 | 601 | See also - every-kv" 602 | [kpred vpred & opts] 603 | (let [desc `(map-of ~(res kpred) ~(res vpred) ~@(res-kind opts))] 604 | `(every-kv ~kpred ~vpred ::conform-all true :kind map? ::describe '~desc ~@opts))) 605 | 606 | 607 | (defmacro * 608 | "Returns a regex op that matches zero or more values matching 609 | pred. Produces a vector of matches iff there is at least one match" 610 | [pred-form] 611 | `(rep-impl '~(res pred-form) ~pred-form)) 612 | 613 | (defmacro + 614 | "Returns a regex op that matches one or more values matching 615 | pred. Produces a vector of matches" 616 | [pred-form] 617 | `(rep+impl '~(res pred-form) ~pred-form)) 618 | 619 | (defmacro ? 620 | "Returns a regex op that matches zero or one value matching 621 | pred. Produces a single value (not a collection) if matched." 622 | [pred-form] 623 | `(maybe-impl ~pred-form '~(res pred-form))) 624 | 625 | (defmacro alt 626 | "Takes key+pred pairs, e.g. 627 | 628 | (s/alt :even even? :small #(< % 42)) 629 | 630 | Returns a regex op that returns a map entry containing the key of the 631 | first matching pred and the corresponding value. Thus the 632 | 'key' and 'val' functions can be used to refer generically to the 633 | components of the tagged return" 634 | [& key-pred-forms] 635 | (let [pairs (partition 2 key-pred-forms) 636 | keys (mapv first pairs) 637 | pred-forms (mapv second pairs) 638 | pf (mapv res pred-forms)] 639 | (c/assert (c/and (even? (count key-pred-forms)) (every? keyword? keys)) "alt expects k1 p1 k2 p2..., where ks are keywords") 640 | `(alt-impl ~keys ~pred-forms '~pf))) 641 | 642 | (defmacro cat 643 | "Takes key+pred pairs, e.g. 644 | 645 | (s/cat :e even? :o odd?) 646 | 647 | Returns a regex op that matches (all) values in sequence, returning a map 648 | containing the keys of each pred and the corresponding value." 649 | [& key-pred-forms] 650 | (let [pairs (partition 2 key-pred-forms) 651 | keys (mapv first pairs) 652 | pred-forms (mapv second pairs) 653 | pf (mapv res pred-forms)] 654 | ;;(prn key-pred-forms) 655 | (c/assert (c/and (even? (count key-pred-forms)) (every? keyword? keys)) "cat expects k1 p1 k2 p2..., where ks are keywords") 656 | `(cat-impl ~keys ~pred-forms '~pf))) 657 | 658 | (defmacro & 659 | "takes a regex op re, and predicates. Returns a regex-op that consumes 660 | input as per re but subjects the resulting value to the 661 | conjunction of the predicates, and any conforming they might perform." 662 | [re & preds] 663 | (let [pv (vec preds)] 664 | `(amp-impl ~re '~(res re) ~pv '~(mapv res pv)))) 665 | 666 | (defmacro conformer 667 | "takes a predicate function with the semantics of conform i.e. it should return either a 668 | (possibly converted) value or :clojure.spec.alpha/invalid, and returns a 669 | spec that uses it as a predicate/conformer. Optionally takes a 670 | second fn that does unform of result of first" 671 | ([f] `(spec-impl '(conformer ~(res f)) ~f nil true)) 672 | ([f unf] `(spec-impl '(conformer ~(res f) ~(res unf)) ~f nil true ~unf))) 673 | 674 | (defmacro fspec 675 | "takes :args :ret and (optional) :fn kwargs whose values are preds 676 | and returns a spec whose conform/explain take a fn and validates it 677 | using generative testing. The conformed value is always the fn itself. 678 | 679 | See 'fdef' for a single operation that creates an fspec and 680 | registers it, as well as a full description of :args, :ret and :fn 681 | 682 | fspecs can generate functions that validate the arguments and 683 | fabricate a return value compliant with the :ret spec, ignoring 684 | the :fn spec if present. 685 | 686 | Optionally takes :gen generator-fn, which must be a fn of no args 687 | that returns a test.check generator." 688 | 689 | [& {:keys [args ret fn gen] :or {ret `any?}}] 690 | `(fspec-impl (spec ~args) '~(res args) 691 | (spec ~ret) '~(res ret) 692 | (spec ~fn) '~(res fn) ~gen)) 693 | 694 | (defmacro tuple 695 | "takes one or more preds and returns a spec for a tuple, a vector 696 | where each element conforms to the corresponding pred. Each element 697 | will be referred to in paths using its ordinal." 698 | [& preds] 699 | (c/assert (not (empty? preds))) 700 | `(tuple-impl '~(mapv res preds) ~(vec preds))) 701 | 702 | (defn- macroexpand-check 703 | [v args] 704 | (let [fn-spec (get-spec v)] 705 | (when-let [arg-spec (:args fn-spec)] 706 | (when (invalid? (conform arg-spec args)) 707 | (let [ed (assoc (explain-data* arg-spec [] 708 | (if-let [name (spec-name arg-spec)] [name] []) [] args) 709 | ::args args)] 710 | (throw (ex-info 711 | (str "Call to " (->sym v) " did not conform to spec.") 712 | ed))))))) 713 | 714 | (defmacro fdef 715 | "Takes a symbol naming a function, and one or more of the following: 716 | 717 | :args A regex spec for the function arguments as they were a list to be 718 | passed to apply - in this way, a single spec can handle functions with 719 | multiple arities 720 | :ret A spec for the function's return value 721 | :fn A spec of the relationship between args and ret - the 722 | value passed is {:args conformed-args :ret conformed-ret} and is 723 | expected to contain predicates that relate those values 724 | 725 | Qualifies fn-sym with resolve, or using *ns* if no resolution found. 726 | Registers an fspec in the global registry, where it can be retrieved 727 | by calling get-spec with the var or fully-qualified symbol. 728 | 729 | Once registered, function specs are included in doc, checked by 730 | instrument, tested by the runner clojure.spec.test/check, and (if 731 | a macro) used to explain errors during macroexpansion. 732 | 733 | Note that :fn specs require the presence of :args and :ret specs to 734 | conform values, and so :fn specs will be ignored if :args or :ret 735 | are missing. 736 | 737 | Returns the qualified fn-sym. 738 | 739 | For example, to register function specs for the symbol function: 740 | 741 | (s/fdef clojure.core/symbol 742 | :args (s/alt :separate (s/cat :ns string? :n string?) 743 | :str string? 744 | :sym symbol?) 745 | :ret symbol?)" 746 | [fn-sym & specs] 747 | `(clojure.spec.alpha/def ~fn-sym (clojure.spec.alpha/fspec ~@specs))) 748 | 749 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; impl ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 750 | (defn- recur-limit? [rmap id path k] 751 | (c/and (> (get rmap id) (::recursion-limit rmap)) 752 | (contains? (set path) k))) 753 | 754 | (defn- inck [m k] 755 | (assoc m k (inc (c/or (get m k) 0)))) 756 | 757 | (defn- dt 758 | ([pred x form] (dt pred x form nil)) 759 | ([pred x form cpred?] 760 | (if pred 761 | (if-let [spec (the-spec pred)] 762 | (conform spec x) 763 | (if (ifn? pred) 764 | (if cpred? 765 | (pred x) 766 | (if (pred x) x ::invalid)) 767 | (throw (Exception. (str (pr-str form) " is not a fn, expected predicate fn"))))) 768 | x))) 769 | 770 | (defn valid? 771 | "Helper function that returns true when x is valid for spec." 772 | ([spec x] 773 | (let [spec (specize spec)] 774 | (not (invalid? (conform* spec x))))) 775 | ([spec x form] 776 | (let [spec (specize spec form)] 777 | (not (invalid? (conform* spec x)))))) 778 | 779 | (defn- pvalid? 780 | "internal helper function that returns true when x is valid for spec." 781 | ([pred x] 782 | (not (invalid? (dt pred x ::unknown)))) 783 | ([pred x form] 784 | (not (invalid? (dt pred x form))))) 785 | 786 | (defn- explain-1 [form pred path via in v] 787 | ;;(prn {:form form :pred pred :path path :in in :v v}) 788 | (let [pred (maybe-spec pred)] 789 | (if (spec? pred) 790 | (explain* pred path (if-let [name (spec-name pred)] (conj via name) via) in v) 791 | [{:path path :pred form :val v :via via :in in}]))) 792 | 793 | (declare or-k-gen and-k-gen) 794 | 795 | (defn- k-gen 796 | "returns a generator for form f, which can be a keyword or a list 797 | starting with 'or or 'and." 798 | [f] 799 | (cond 800 | (keyword? f) (gen/return f) 801 | (= 'or (first f)) (or-k-gen 1 (rest f)) 802 | (= 'and (first f)) (and-k-gen (rest f)))) 803 | 804 | (defn- or-k-gen 805 | "returns a tuple generator made up of generators for a random subset 806 | of min-count (default 0) to all elements in s." 807 | ([s] (or-k-gen 0 s)) 808 | ([min-count s] 809 | (gen/bind (gen/tuple 810 | (gen/choose min-count (count s)) 811 | (gen/shuffle (map k-gen s))) 812 | (fn [[n gens]] 813 | (apply gen/tuple (take n gens)))))) 814 | 815 | (defn- and-k-gen 816 | "returns a tuple generator made up of generators for every element 817 | in s." 818 | [s] 819 | (apply gen/tuple (map k-gen s))) 820 | 821 | 822 | (defn ^:skip-wiki map-spec-impl 823 | "Do not call this directly, use 'spec' with a map argument" 824 | [{:keys [req-un opt-un keys-pred pred-exprs opt-keys req-specs req req-keys opt-specs pred-forms opt gfn] 825 | :as argm}] 826 | (let [k->s (zipmap (concat req-keys opt-keys) (concat req-specs opt-specs)) 827 | keys->specnames #(c/or (k->s %) %) 828 | id (System.Guid/NewGuid)] ;;; java.util.UUID/randomUUID 829 | (reify 830 | Specize 831 | (specize* [s] s) 832 | (specize* [s _] s) 833 | 834 | Spec 835 | (conform* [_ m] 836 | (if (keys-pred m) 837 | (let [reg (registry)] 838 | (loop [ret m, [[k v] & ks :as keys] m] 839 | (if keys 840 | (let [sname (keys->specnames k)] 841 | (if-let [s (get reg sname)] 842 | (let [cv (conform s v)] 843 | (if (invalid? cv) 844 | ::invalid 845 | (recur (if (identical? cv v) ret (assoc ret k cv)) 846 | ks))) 847 | (recur ret ks))) 848 | ret))) 849 | ::invalid)) 850 | (unform* [_ m] 851 | (let [reg (registry)] 852 | (loop [ret m, [k & ks :as keys] (c/keys m)] 853 | (if keys 854 | (if (contains? reg (keys->specnames k)) 855 | (let [cv (get m k) 856 | v (unform (keys->specnames k) cv)] 857 | (recur (if (identical? cv v) ret (assoc ret k v)) 858 | ks)) 859 | (recur ret ks)) 860 | ret)))) 861 | (explain* [_ path via in x] 862 | (if-not (map? x) 863 | [{:path path :pred `map? :val x :via via :in in}] 864 | (let [reg (registry)] 865 | (apply concat 866 | (when-let [probs (->> (map (fn [pred form] (when-not (pred x) form)) 867 | pred-exprs pred-forms) 868 | (keep identity) 869 | seq)] 870 | (map 871 | #(identity {:path path :pred % :val x :via via :in in}) 872 | probs)) 873 | (map (fn [[k v]] 874 | (when-not (c/or (not (contains? reg (keys->specnames k))) 875 | (pvalid? (keys->specnames k) v k)) 876 | (explain-1 (keys->specnames k) (keys->specnames k) (conj path k) via (conj in k) v))) 877 | (seq x)))))) 878 | (gen* [_ overrides path rmap] 879 | (if gfn 880 | (gfn) 881 | (let [rmap (inck rmap id) 882 | rgen (fn [k s] [k (gensub s overrides (conj path k) rmap k)]) 883 | ogen (fn [k s] 884 | (when-not (recur-limit? rmap id path k) 885 | [k (gen/delay (gensub s overrides (conj path k) rmap k))])) 886 | reqs (map rgen req-keys req-specs) 887 | opts (remove nil? (map ogen opt-keys opt-specs))] 888 | (when (every? identity (concat (map second reqs) (map second opts))) 889 | (gen/bind 890 | (gen/tuple 891 | (and-k-gen req) 892 | (or-k-gen opt) 893 | (and-k-gen req-un) 894 | (or-k-gen opt-un)) 895 | (fn [[req-ks opt-ks req-un-ks opt-un-ks]] 896 | (let [qks (flatten (concat req-ks opt-ks)) 897 | unqks (map (comp keyword name) (flatten (concat req-un-ks opt-un-ks)))] 898 | (->> (into reqs opts) 899 | (filter #((set (concat qks unqks)) (first %))) 900 | (apply concat) 901 | (apply gen/hash-map))))))))) 902 | (with-gen* [_ gfn] (map-spec-impl (assoc argm :gfn gfn))) 903 | (describe* [_] (cons `keys 904 | (cond-> [] 905 | req (conj :req req) 906 | opt (conj :opt opt) 907 | req-un (conj :req-un req-un) 908 | opt-un (conj :opt-un opt-un))))))) 909 | 910 | 911 | 912 | 913 | (defn ^:skip-wiki spec-impl 914 | "Do not call this directly, use 'spec'" 915 | ([form pred gfn cpred?] (spec-impl form pred gfn cpred? nil)) 916 | ([form pred gfn cpred? unc] 917 | (cond 918 | (spec? pred) (cond-> pred gfn (with-gen gfn)) 919 | (regex? pred) (regex-spec-impl pred gfn) 920 | (ident? pred) (cond-> (the-spec pred) gfn (with-gen gfn)) 921 | :else 922 | (reify 923 | Specize 924 | (specize* [s] s) 925 | (specize* [s _] s) 926 | 927 | Spec 928 | (conform* [_ x] (let [ret (pred x)] 929 | (if cpred? 930 | ret 931 | (if ret x ::invalid)))) 932 | (unform* [_ x] (if cpred? 933 | (if unc 934 | (unc x) 935 | (throw (InvalidOperationException. "no unform fn for conformer"))) ;;; IllegalStateException. 936 | x)) 937 | (explain* [_ path via in x] 938 | (when (invalid? (dt pred x form cpred?)) 939 | [{:path path :pred form :val x :via via :in in}])) 940 | (gen* [_ _ _ _] (if gfn 941 | (gfn) 942 | (gen/gen-for-pred pred))) 943 | (with-gen* [_ gfn] (spec-impl form pred gfn cpred? unc)) 944 | (describe* [_] form))))) 945 | 946 | (defn ^:skip-wiki multi-spec-impl 947 | "Do not call this directly, use 'multi-spec'" 948 | ([form mmvar retag] (multi-spec-impl form mmvar retag nil)) 949 | ([form mmvar retag gfn] 950 | (let [id (System.Guid/NewGuid) ;;; java.util.UUID/randomUUID 951 | predx #(let [^clojure.lang.MultiFn mm @mmvar] 952 | (c/and (.getMethod mm ((.dispatchFn mm) %)) 953 | (mm %))) 954 | dval #((.dispatchFn ^clojure.lang.MultiFn @mmvar) %) 955 | tag (if (keyword? retag) 956 | #(assoc %1 retag %2) 957 | retag)] 958 | (reify 959 | Specize 960 | (specize* [s] s) 961 | (specize* [s _] s) 962 | 963 | Spec 964 | (conform* [_ x] (if-let [pred (predx x)] 965 | (dt pred x form) 966 | ::invalid)) 967 | (unform* [_ x] (if-let [pred (predx x)] 968 | (unform pred x) 969 | (throw (InvalidOperationException. (str "No method of: " form " for dispatch value: " (dval x)))))) ;;; IllegalStateException. 970 | (explain* [_ path via in x] 971 | (let [dv (dval x) 972 | path (conj path dv)] 973 | (if-let [pred (predx x)] 974 | (explain-1 form pred path via in x) 975 | [{:path path :pred form :val x :reason "no method" :via via :in in}]))) 976 | (gen* [_ overrides path rmap] 977 | (if gfn 978 | (gfn) 979 | (let [gen (fn [[k f]] 980 | (let [p (f nil)] 981 | (let [rmap (inck rmap id)] 982 | (when-not (recur-limit? rmap id path k) 983 | (gen/delay 984 | (gen/fmap 985 | #(tag % k) 986 | (gensub p overrides (conj path k) rmap (list 'method form k)))))))) 987 | gs (->> (methods @mmvar) 988 | (remove (fn [[k]] (invalid? k))) 989 | (map gen) 990 | (remove nil?))] 991 | (when (every? identity gs) 992 | (gen/one-of gs))))) 993 | (with-gen* [_ gfn] (multi-spec-impl form mmvar retag gfn)) 994 | (describe* [_] `(multi-spec ~form ~retag)))))) 995 | 996 | (defn ^:skip-wiki tuple-impl 997 | "Do not call this directly, use 'tuple'" 998 | ([forms preds] (tuple-impl forms preds nil)) 999 | ([forms preds gfn] 1000 | (let [specs (delay (mapv specize preds forms)) 1001 | cnt (count preds)] 1002 | (reify 1003 | Specize 1004 | (specize* [s] s) 1005 | (specize* [s _] s) 1006 | 1007 | Spec 1008 | (conform* [_ x] 1009 | (let [specs @specs] 1010 | (if-not (c/and (vector? x) 1011 | (= (count x) cnt)) 1012 | ::invalid 1013 | (loop [ret x, i 0] 1014 | (if (= i cnt) 1015 | ret 1016 | (let [v (x i) 1017 | cv (conform* (specs i) v)] 1018 | (if (invalid? cv) 1019 | ::invalid 1020 | (recur (if (identical? cv v) ret (assoc ret i cv)) 1021 | (inc i))))))))) 1022 | (unform* [_ x] 1023 | (c/assert (c/and (vector? x) 1024 | (= (count x) (count preds)))) 1025 | (loop [ret x, i 0] 1026 | (if (= i (count x)) 1027 | ret 1028 | (let [cv (x i) 1029 | v (unform (preds i) cv)] 1030 | (recur (if (identical? cv v) ret (assoc ret i v)) 1031 | (inc i)))))) 1032 | (explain* [_ path via in x] 1033 | (cond 1034 | (not (vector? x)) 1035 | [{:path path :pred `vector? :val x :via via :in in}] 1036 | 1037 | (not= (count x) (count preds)) 1038 | [{:path path :pred `(= (count ~'%) ~(count preds)) :val x :via via :in in}] 1039 | 1040 | :else 1041 | (apply concat 1042 | (map (fn [i form pred] 1043 | (let [v (x i)] 1044 | (when-not (pvalid? pred v) 1045 | (explain-1 form pred (conj path i) via (conj in i) v)))) 1046 | (range (count preds)) forms preds)))) 1047 | (gen* [_ overrides path rmap] 1048 | (if gfn 1049 | (gfn) 1050 | (let [gen (fn [i p f] 1051 | (gensub p overrides (conj path i) rmap f)) 1052 | gs (map gen (range (count preds)) preds forms)] 1053 | (when (every? identity gs) 1054 | (apply gen/tuple gs))))) 1055 | (with-gen* [_ gfn] (tuple-impl forms preds gfn)) 1056 | (describe* [_] `(tuple ~@forms)))))) 1057 | 1058 | (defn- tagged-ret [tag ret] 1059 | (clojure.lang.MapEntry. tag ret)) 1060 | 1061 | (defn ^:skip-wiki or-spec-impl 1062 | "Do not call this directly, use 'or'" 1063 | [keys forms preds gfn] 1064 | (let [id (System.Guid/NewGuid) ;;; java.util.UUID/randomUUID 1065 | kps (zipmap keys preds) 1066 | specs (delay (mapv specize preds forms)) 1067 | cform (case (count preds) 1068 | 2 (fn [x] 1069 | (let [specs @specs 1070 | ret (conform* (specs 0) x)] 1071 | (if (invalid? ret) 1072 | (let [ret (conform* (specs 1) x)] 1073 | (if (invalid? ret) 1074 | ::invalid 1075 | (tagged-ret (keys 1) ret))) 1076 | (tagged-ret (keys 0) ret)))) 1077 | 3 (fn [x] 1078 | (let [specs @specs 1079 | ret (conform* (specs 0) x)] 1080 | (if (invalid? ret) 1081 | (let [ret (conform* (specs 1) x)] 1082 | (if (invalid? ret) 1083 | (let [ret (conform* (specs 2) x)] 1084 | (if (invalid? ret) 1085 | ::invalid 1086 | (tagged-ret (keys 2) ret))) 1087 | (tagged-ret (keys 1) ret))) 1088 | (tagged-ret (keys 0) ret)))) 1089 | (fn [x] 1090 | (let [specs @specs] 1091 | (loop [i 0] 1092 | (if (< i (count specs)) 1093 | (let [spec (specs i)] 1094 | (let [ret (conform* spec x)] 1095 | (if (invalid? ret) 1096 | (recur (inc i)) 1097 | (tagged-ret (keys i) ret)))) 1098 | ::invalid)))))] 1099 | (reify 1100 | Specize 1101 | (specize* [s] s) 1102 | (specize* [s _] s) 1103 | 1104 | Spec 1105 | (conform* [_ x] (cform x)) 1106 | (unform* [_ [k x]] (unform (kps k) x)) 1107 | (explain* [this path via in x] 1108 | (when-not (pvalid? this x) 1109 | (apply concat 1110 | (map (fn [k form pred] 1111 | (when-not (pvalid? pred x) 1112 | (explain-1 form pred (conj path k) via in x))) 1113 | keys forms preds)))) 1114 | (gen* [_ overrides path rmap] 1115 | (if gfn 1116 | (gfn) 1117 | (let [gen (fn [k p f] 1118 | (let [rmap (inck rmap id)] 1119 | (when-not (recur-limit? rmap id path k) 1120 | (gen/delay 1121 | (gensub p overrides (conj path k) rmap f))))) 1122 | gs (remove nil? (map gen keys preds forms))] 1123 | (when-not (empty? gs) 1124 | (gen/one-of gs))))) 1125 | (with-gen* [_ gfn] (or-spec-impl keys forms preds gfn)) 1126 | (describe* [_] `(or ~@(mapcat vector keys forms)))))) 1127 | 1128 | (defn- and-preds [x preds forms] 1129 | (loop [ret x 1130 | [pred & preds] preds 1131 | [form & forms] forms] 1132 | (if pred 1133 | (let [nret (dt pred ret form)] 1134 | (if (invalid? nret) 1135 | ::invalid 1136 | ;;propagate conformed values 1137 | (recur nret preds forms))) 1138 | ret))) 1139 | 1140 | (defn- explain-pred-list 1141 | [forms preds path via in x] 1142 | (loop [ret x 1143 | [form & forms] forms 1144 | [pred & preds] preds] 1145 | (when pred 1146 | (let [nret (dt pred ret form)] 1147 | (if (invalid? nret) 1148 | (explain-1 form pred path via in ret) 1149 | (recur nret forms preds)))))) 1150 | 1151 | (defn ^:skip-wiki and-spec-impl 1152 | "Do not call this directly, use 'and'" 1153 | [forms preds gfn] 1154 | (let [specs (delay (mapv specize preds forms)) 1155 | cform 1156 | (case (count preds) 1157 | 2 (fn [x] 1158 | (let [specs @specs 1159 | ret (conform* (specs 0) x)] 1160 | (if (invalid? ret) 1161 | ::invalid 1162 | (conform* (specs 1) ret)))) 1163 | 3 (fn [x] 1164 | (let [specs @specs 1165 | ret (conform* (specs 0) x)] 1166 | (if (invalid? ret) 1167 | ::invalid 1168 | (let [ret (conform* (specs 1) ret)] 1169 | (if (invalid? ret) 1170 | ::invalid 1171 | (conform* (specs 2) ret)))))) 1172 | (fn [x] 1173 | (let [specs @specs] 1174 | (loop [ret x i 0] 1175 | (if (< i (count specs)) 1176 | (let [nret (conform* (specs i) ret)] 1177 | (if (invalid? nret) 1178 | ::invalid 1179 | ;;propagate conformed values 1180 | (recur nret (inc i)))) 1181 | ret)))))] 1182 | (reify 1183 | Specize 1184 | (specize* [s] s) 1185 | (specize* [s _] s) 1186 | 1187 | Spec 1188 | (conform* [_ x] (cform x)) 1189 | (unform* [_ x] (reduce #(unform %2 %1) x (reverse preds))) 1190 | (explain* [_ path via in x] (explain-pred-list forms preds path via in x)) 1191 | (gen* [_ overrides path rmap] (if gfn (gfn) (gensub (first preds) overrides path rmap (first forms)))) 1192 | (with-gen* [_ gfn] (and-spec-impl forms preds gfn)) 1193 | (describe* [_] `(and ~@forms))))) 1194 | 1195 | (defn ^:skip-wiki merge-spec-impl 1196 | "Do not call this directly, use 'merge'" 1197 | [forms preds gfn] 1198 | (reify 1199 | Specize 1200 | (specize* [s] s) 1201 | (specize* [s _] s) 1202 | 1203 | Spec 1204 | (conform* [_ x] (let [ms (map #(dt %1 x %2) preds forms)] 1205 | (if (some invalid? ms) 1206 | ::invalid 1207 | (apply c/merge ms)))) 1208 | (unform* [_ x] (apply c/merge (map #(unform % x) (reverse preds)))) 1209 | (explain* [_ path via in x] 1210 | (apply concat 1211 | (map #(explain-1 %1 %2 path via in x) 1212 | forms preds))) 1213 | (gen* [_ overrides path rmap] 1214 | (if gfn 1215 | (gfn) 1216 | (gen/fmap 1217 | #(apply c/merge %) 1218 | (apply gen/tuple (map #(gensub %1 overrides path rmap %2) 1219 | preds forms))))) 1220 | (with-gen* [_ gfn] (merge-spec-impl forms preds gfn)) 1221 | (describe* [_] `(merge ~@forms)))) 1222 | 1223 | (defn- coll-prob [x kfn kform distinct count min-count max-count 1224 | path via in] 1225 | (let [pred (c/or kfn coll?) 1226 | kform (c/or kform `coll?)] 1227 | (cond 1228 | (not (pvalid? pred x)) 1229 | (explain-1 kform pred path via in x) 1230 | 1231 | (c/and count (not= count (bounded-count count x))) 1232 | [{:path path :pred `(= ~count (c/count ~'%)) :val x :via via :in in}] 1233 | 1234 | (c/and (c/or min-count max-count) 1235 | (not (<= (c/or min-count 0) 1236 | (bounded-count (if max-count (inc max-count) min-count) x) 1237 | (c/or max-count Int64/MaxValue)))) ;;; Integer/MAX_VALUE 1238 | [{:path path :pred `(<= ~(c/or min-count 0) (c/count ~'%) ~(c/or max-count 'Int64/MaxValue)) :val x :via via :in in}] ;;; Integer/MAX_VALUE 1239 | 1240 | (c/and distinct (not (empty? x)) (not (apply distinct? x))) 1241 | [{:path path :pred 'distinct? :val x :via via :in in}]))) 1242 | 1243 | (def ^:private empty-coll {`vector? [], `set? #{}, `list? (), `map? {}}) 1244 | 1245 | (defn ^:skip-wiki every-impl 1246 | "Do not call this directly, use 'every', 'every-kv', 'coll-of' or 'map-of'" 1247 | ([form pred opts] (every-impl form pred opts nil)) 1248 | ([form pred {conform-into :into 1249 | describe-form ::describe 1250 | :keys [kind ::kind-form count max-count min-count distinct gen-max ::kfn ::cpred 1251 | conform-keys ::conform-all] 1252 | :or {gen-max 20} 1253 | :as opts} 1254 | gfn] 1255 | (let [gen-into (if conform-into (empty conform-into) (get empty-coll kind-form)) 1256 | spec (delay (specize pred)) 1257 | check? #(valid? @spec %) 1258 | kfn (c/or kfn (fn [i v] i)) 1259 | addcv (fn [ret i v cv] (conj ret cv)) 1260 | cfns (fn [x] 1261 | ;;returns a tuple of [init add complete] fns 1262 | (cond 1263 | (c/and (vector? x) (c/or (not conform-into) (vector? conform-into))) 1264 | [identity 1265 | (fn [ret i v cv] 1266 | (if (identical? v cv) 1267 | ret 1268 | (assoc ret i cv))) 1269 | identity] 1270 | 1271 | (c/and (map? x) (c/or (c/and kind (not conform-into)) (map? conform-into))) 1272 | [(if conform-keys empty identity) 1273 | (fn [ret i v cv] 1274 | (if (c/and (identical? v cv) (not conform-keys)) 1275 | ret 1276 | (assoc ret (nth (if conform-keys cv v) 0) (nth cv 1)))) 1277 | identity] 1278 | 1279 | (c/or (list? conform-into) (seq? conform-into) (c/and (not conform-into) (c/or (list? x) (seq? x)))) 1280 | [(constantly ()) addcv reverse] 1281 | 1282 | :else [#(empty (c/or conform-into %)) addcv identity]))] 1283 | (reify 1284 | Specize 1285 | (specize* [s] s) 1286 | (specize* [s _] s) 1287 | 1288 | Spec 1289 | (conform* [_ x] 1290 | (let [spec @spec] 1291 | (cond 1292 | (not (cpred x)) ::invalid 1293 | 1294 | conform-all 1295 | (let [[init add complete] (cfns x)] 1296 | (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)] 1297 | (if vseq 1298 | (let [cv (conform* spec v)] 1299 | (if (invalid? cv) 1300 | ::invalid 1301 | (recur (add ret i v cv) (inc i) vs))) 1302 | (complete ret)))) 1303 | 1304 | 1305 | :else 1306 | (if (indexed? x) 1307 | (let [step (max 1 (long (/ (c/count x) *coll-check-limit*)))] 1308 | (loop [i 0] 1309 | (if (>= i (c/count x)) 1310 | x 1311 | (if (valid? spec (nth x i)) 1312 | (recur (c/+ i step)) 1313 | ::invalid)))) 1314 | (let [limit *coll-check-limit*] 1315 | (loop [i 0 [v & vs :as vseq] (seq x)] 1316 | (cond 1317 | (c/or (nil? vseq) (= i limit)) x 1318 | (valid? spec v) (recur (inc i) vs) 1319 | :else ::invalid))))))) 1320 | (unform* [_ x] 1321 | (if conform-all 1322 | (let [spec @spec 1323 | [init add complete] (cfns x)] 1324 | (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)] 1325 | (if (>= i (c/count x)) 1326 | (complete ret) 1327 | (recur (add ret i v (unform* spec v)) (inc i) vs)))) 1328 | x)) 1329 | (explain* [_ path via in x] 1330 | (c/or (coll-prob x kind kind-form distinct count min-count max-count 1331 | path via in) 1332 | (apply concat 1333 | ((if conform-all identity (partial take *coll-error-limit*)) 1334 | (keep identity 1335 | (map (fn [i v] 1336 | (let [k (kfn i v)] 1337 | (when-not (check? v) 1338 | (let [prob (explain-1 form pred path via (conj in k) v)] 1339 | prob)))) 1340 | (range) x)))))) 1341 | (gen* [_ overrides path rmap] 1342 | (if gfn 1343 | (gfn) 1344 | (let [pgen (gensub pred overrides path rmap form)] 1345 | (gen/bind 1346 | (cond 1347 | gen-into (gen/return gen-into) 1348 | kind (gen/fmap #(if (empty? %) % (empty %)) 1349 | (gensub kind overrides path rmap form)) 1350 | :else (gen/return [])) 1351 | (fn [init] 1352 | (gen/fmap 1353 | #(if (vector? init) % (into init %)) 1354 | (cond 1355 | distinct 1356 | (if count 1357 | (gen/vector-distinct pgen {:num-elements count :max-tries 100}) 1358 | (gen/vector-distinct pgen {:min-elements (c/or min-count 0) 1359 | :max-elements (c/or max-count (max gen-max (c/* 2 (c/or min-count 0)))) 1360 | :max-tries 100})) 1361 | 1362 | count 1363 | (gen/vector pgen count) 1364 | 1365 | (c/or min-count max-count) 1366 | (gen/vector pgen (c/or min-count 0) (c/or max-count (max gen-max (c/* 2 (c/or min-count 0))))) 1367 | 1368 | :else 1369 | (gen/vector pgen 0 gen-max)))))))) 1370 | 1371 | (with-gen* [_ gfn] (every-impl form pred opts gfn)) 1372 | (describe* [_] (c/or describe-form `(every ~(res form) ~@(mapcat identity opts)))))))) 1373 | 1374 | ;;;;;;;;;;;;;;;;;;;;;;; regex ;;;;;;;;;;;;;;;;;;; 1375 | ;;See: 1376 | ;; http://matt.might.net/articles/implementation-of-regular-expression-matching-in-scheme-with-derivatives/ 1377 | ;; http://www.ccs.neu.edu/home/turon/re-deriv.pdf 1378 | 1379 | ;;ctors 1380 | (defn- accept [x] {::op ::accept :ret x}) 1381 | 1382 | (defn- accept? [{:keys [::op]}] 1383 | (= ::accept op)) 1384 | 1385 | (defn- pcat* [{[p1 & pr :as ps] :ps, [k1 & kr :as ks] :ks, [f1 & fr :as forms] :forms, ret :ret, rep+ :rep+}] 1386 | (when (every? identity ps) 1387 | (if (accept? p1) 1388 | (let [rp (:ret p1) 1389 | ret (conj ret (if ks {k1 rp} rp))] 1390 | (if pr 1391 | (pcat* {:ps pr :ks kr :forms fr :ret ret}) 1392 | (accept ret))) 1393 | {::op ::pcat, :ps ps, :ret ret, :ks ks, :forms forms :rep+ rep+}))) 1394 | 1395 | (defn- pcat [& ps] (pcat* {:ps ps :ret []})) 1396 | 1397 | (defn ^:skip-wiki cat-impl 1398 | "Do not call this directly, use 'cat'" 1399 | [ks ps forms] 1400 | (pcat* {:ks ks, :ps ps, :forms forms, :ret {}})) 1401 | 1402 | (defn- rep* [p1 p2 ret splice form] 1403 | (when p1 1404 | (let [r {::op ::rep, :p2 p2, :splice splice, :forms form :id (System.Guid/NewGuid)}] ;;; java.util.UUID/randomUUID 1405 | (if (accept? p1) 1406 | (assoc r :p1 p2 :ret (conj ret (:ret p1))) 1407 | (assoc r :p1 p1, :ret ret))))) 1408 | 1409 | (defn ^:skip-wiki rep-impl 1410 | "Do not call this directly, use '*'" 1411 | [form p] (rep* p p [] false form)) 1412 | 1413 | (defn ^:skip-wiki rep+impl 1414 | "Do not call this directly, use '+'" 1415 | [form p] 1416 | (pcat* {:ps [p (rep* p p [] true form)] :forms `[~form (* ~form)] :ret [] :rep+ form})) 1417 | 1418 | (defn ^:skip-wiki amp-impl 1419 | "Do not call this directly, use '&'" 1420 | [re re-form preds pred-forms] 1421 | {::op ::amp :p1 re :amp re-form :ps preds :forms pred-forms}) 1422 | 1423 | (defn- filter-alt [ps ks forms f] 1424 | (if (c/or ks forms) 1425 | (let [pks (->> (map vector ps 1426 | (c/or (seq ks) (repeat nil)) 1427 | (c/or (seq forms) (repeat nil))) 1428 | (filter #(-> % first f)))] 1429 | [(seq (map first pks)) (when ks (seq (map second pks))) (when forms (seq (map #(nth % 2) pks)))]) 1430 | [(seq (filter f ps)) ks forms])) 1431 | 1432 | (defn- alt* [ps ks forms] 1433 | (let [[[p1 & pr :as ps] [k1 :as ks] forms] (filter-alt ps ks forms identity)] 1434 | (when ps 1435 | (let [ret {::op ::alt, :ps ps, :ks ks :forms forms}] 1436 | (if (nil? pr) 1437 | (if k1 1438 | (if (accept? p1) 1439 | (accept (tagged-ret k1 (:ret p1))) 1440 | ret) 1441 | p1) 1442 | ret))))) 1443 | 1444 | (defn- alts [& ps] (alt* ps nil nil)) 1445 | (defn- alt2 [p1 p2] (if (c/and p1 p2) (alts p1 p2) (c/or p1 p2))) 1446 | 1447 | (defn ^:skip-wiki alt-impl 1448 | "Do not call this directly, use 'alt'" 1449 | [ks ps forms] (assoc (alt* ps ks forms) :id (System.Guid/NewGuid))) ;;; java.util.UUID/randomUUID 1450 | 1451 | (defn ^:skip-wiki maybe-impl 1452 | "Do not call this directly, use '?'" 1453 | [p form] (assoc (alt* [p (accept ::nil)] nil [form ::nil]) :maybe form)) 1454 | 1455 | (defn- noret? [p1 pret] 1456 | (c/or (= pret ::nil) 1457 | (c/and (#{::rep ::pcat} (::op (reg-resolve! p1))) ;;hrm, shouldn't know these 1458 | (empty? pret)) 1459 | nil)) 1460 | 1461 | (declare preturn) 1462 | 1463 | (defn- accept-nil? [p] 1464 | (let [{:keys [::op ps p1 p2 forms] :as p} (reg-resolve! p)] 1465 | (case op 1466 | ::accept true 1467 | nil nil 1468 | ::amp (c/and (accept-nil? p1) 1469 | (let [ret (-> (preturn p1) (and-preds ps (next forms)))] 1470 | (not (invalid? ret)))) 1471 | ::rep (c/or (identical? p1 p2) (accept-nil? p1)) 1472 | ::pcat (every? accept-nil? ps) 1473 | ::alt (c/some accept-nil? ps)))) 1474 | 1475 | (declare add-ret) 1476 | 1477 | (defn- preturn [p] 1478 | (let [{[p0 & pr :as ps] :ps, [k :as ks] :ks, :keys [::op p1 ret forms] :as p} (reg-resolve! p)] 1479 | (case op 1480 | ::accept ret 1481 | nil nil 1482 | ::amp (let [pret (preturn p1)] 1483 | (if (noret? p1 pret) 1484 | ::nil 1485 | (and-preds pret ps forms))) 1486 | ::rep (add-ret p1 ret k) 1487 | ::pcat (add-ret p0 ret k) 1488 | ::alt (let [[[p0] [k0]] (filter-alt ps ks forms accept-nil?) 1489 | r (if (nil? p0) ::nil (preturn p0))] 1490 | (if k0 (tagged-ret k0 r) r))))) 1491 | 1492 | (defn- op-unform [p x] 1493 | ;;(prn {:p p :x x}) 1494 | (let [{[p0 & pr :as ps] :ps, [k :as ks] :ks, :keys [::op p1 ret forms rep+ maybe] :as p} (reg-resolve! p) 1495 | kps (zipmap ks ps)] 1496 | (case op 1497 | ::accept [ret] 1498 | nil [(unform p x)] 1499 | ::amp (let [px (reduce #(unform %2 %1) x (reverse ps))] 1500 | (op-unform p1 px)) 1501 | ::rep (mapcat #(op-unform p1 %) x) 1502 | ::pcat (if rep+ 1503 | (mapcat #(op-unform p0 %) x) 1504 | (mapcat (fn [k] 1505 | (when (contains? x k) 1506 | (op-unform (kps k) (get x k)))) 1507 | ks)) 1508 | ::alt (if maybe 1509 | [(unform p0 x)] 1510 | (let [[k v] x] 1511 | (op-unform (kps k) v)))))) 1512 | 1513 | (defn- add-ret [p r k] 1514 | (let [{:keys [::op ps splice] :as p} (reg-resolve! p) 1515 | prop #(let [ret (preturn p)] 1516 | (if (empty? ret) r ((if splice into conj) r (if k {k ret} ret))))] 1517 | (case op 1518 | nil r 1519 | (::alt ::accept ::amp) 1520 | (let [ret (preturn p)] 1521 | ;;(prn {:ret ret}) 1522 | (if (= ret ::nil) r (conj r (if k {k ret} ret)))) 1523 | 1524 | (::rep ::pcat) (prop)))) 1525 | 1526 | (defn- deriv 1527 | [p x] 1528 | (let [{[p0 & pr :as ps] :ps, [k0 & kr :as ks] :ks, :keys [::op p1 p2 ret splice forms amp] :as p} (reg-resolve! p)] 1529 | (when p 1530 | (case op 1531 | ::accept nil 1532 | nil (let [ret (dt p x p)] 1533 | (when-not (invalid? ret) (accept ret))) 1534 | ::amp (when-let [p1 (deriv p1 x)] 1535 | (if (= ::accept (::op p1)) 1536 | (let [ret (-> (preturn p1) (and-preds ps (next forms)))] 1537 | (when-not (invalid? ret) 1538 | (accept ret))) 1539 | (amp-impl p1 amp ps forms))) 1540 | ::pcat (alt2 (pcat* {:ps (cons (deriv p0 x) pr), :ks ks, :forms forms, :ret ret}) 1541 | (when (accept-nil? p0) (deriv (pcat* {:ps pr, :ks kr, :forms (next forms), :ret (add-ret p0 ret k0)}) x))) 1542 | ::alt (alt* (map #(deriv % x) ps) ks forms) 1543 | ::rep (alt2 (rep* (deriv p1 x) p2 ret splice forms) 1544 | (when (accept-nil? p1) (deriv (rep* p2 p2 (add-ret p1 ret nil) splice forms) x))))))) 1545 | 1546 | (defn- op-describe [p] 1547 | (let [{:keys [::op ps ks forms splice p1 rep+ maybe amp] :as p} (reg-resolve! p)] 1548 | ;;(prn {:op op :ks ks :forms forms :p p}) 1549 | (when p 1550 | (case op 1551 | ::accept nil 1552 | nil p 1553 | ::amp (list* 'clojure.spec.alpha/& amp forms) 1554 | ::pcat (if rep+ 1555 | (list `+ rep+) 1556 | (cons `cat (mapcat vector (c/or (seq ks) (repeat :_)) forms))) 1557 | ::alt (if maybe 1558 | (list `? maybe) 1559 | (cons `alt (mapcat vector ks forms))) 1560 | ::rep (list (if splice `+ `*) forms))))) 1561 | 1562 | (defn- op-explain [form p path via in input] 1563 | ;;(prn {:form form :p p :path path :input input}) 1564 | (let [[x :as input] input 1565 | {:keys [::op ps ks forms splice p1 p2] :as p} (reg-resolve! p) 1566 | via (if-let [name (spec-name p)] (conj via name) via) 1567 | insufficient (fn [path form] 1568 | [{:path path 1569 | :reason "Insufficient input" 1570 | :pred form 1571 | :val () 1572 | :via via 1573 | :in in}])] 1574 | (when p 1575 | (case op 1576 | ::accept nil 1577 | nil (if (empty? input) 1578 | (insufficient path form) 1579 | (explain-1 form p path via in x)) 1580 | ::amp (if (empty? input) 1581 | (if (accept-nil? p1) 1582 | (explain-pred-list forms ps path via in (preturn p1)) 1583 | (insufficient path (:amp p))) 1584 | (if-let [p1 (deriv p1 x)] 1585 | (explain-pred-list forms ps path via in (preturn p1)) 1586 | (op-explain (:amp p) p1 path via in input))) 1587 | ::pcat (let [pkfs (map vector 1588 | ps 1589 | (c/or (seq ks) (repeat nil)) 1590 | (c/or (seq forms) (repeat nil))) 1591 | [pred k form] (if (= 1 (count pkfs)) 1592 | (first pkfs) 1593 | (first (remove (fn [[p]] (accept-nil? p)) pkfs))) 1594 | path (if k (conj path k) path) 1595 | form (c/or form (op-describe pred))] 1596 | (if (c/and (empty? input) (not pred)) 1597 | (insufficient path form) 1598 | (op-explain form pred path via in input))) 1599 | ::alt (if (empty? input) 1600 | (insufficient path (op-describe p)) 1601 | (apply concat 1602 | (map (fn [k form pred] 1603 | (op-explain (c/or form (op-describe pred)) 1604 | pred 1605 | (if k (conj path k) path) 1606 | via 1607 | in 1608 | input)) 1609 | (c/or (seq ks) (repeat nil)) 1610 | (c/or (seq forms) (repeat nil)) 1611 | ps))) 1612 | ::rep (op-explain (if (identical? p1 p2) 1613 | forms 1614 | (op-describe p1)) 1615 | p1 path via in input))))) 1616 | 1617 | (defn- re-gen [p overrides path rmap f] 1618 | ;;(prn {:op op :ks ks :forms forms}) 1619 | (let [origp p 1620 | {:keys [::op ps ks p1 p2 forms splice ret id ::gfn] :as p} (reg-resolve! p) 1621 | rmap (if id (inck rmap id) rmap) 1622 | ggens (fn [ps ks forms] 1623 | (let [gen (fn [p k f] 1624 | ;;(prn {:k k :path path :rmap rmap :op op :id id}) 1625 | (when-not (c/and rmap id k (recur-limit? rmap id path k)) 1626 | (if id 1627 | (gen/delay (re-gen p overrides (if k (conj path k) path) rmap (c/or f p))) 1628 | (re-gen p overrides (if k (conj path k) path) rmap (c/or f p)))))] 1629 | (map gen ps (c/or (seq ks) (repeat nil)) (c/or (seq forms) (repeat nil)))))] 1630 | (c/or (when-let [gfn (c/or (get overrides (spec-name origp)) 1631 | (get overrides (spec-name p) ) 1632 | (get overrides path))] 1633 | (case op 1634 | (:accept nil) (gen/fmap vector (gfn)) 1635 | (gfn))) 1636 | (when gfn 1637 | (gfn)) 1638 | (when p 1639 | (case op 1640 | ::accept (if (= ret ::nil) 1641 | (gen/return []) 1642 | (gen/return [ret])) 1643 | nil (when-let [g (gensub p overrides path rmap f)] 1644 | (gen/fmap vector g)) 1645 | ::amp (re-gen p1 overrides path rmap (op-describe p1)) 1646 | ::pcat (let [gens (ggens ps ks forms)] 1647 | (when (every? identity gens) 1648 | (apply gen/cat gens))) 1649 | ::alt (let [gens (remove nil? (ggens ps ks forms))] 1650 | (when-not (empty? gens) 1651 | (gen/one-of gens))) 1652 | ::rep (if (recur-limit? rmap id [id] id) 1653 | (gen/return []) 1654 | (when-let [g (re-gen p2 overrides path rmap forms)] 1655 | (gen/fmap #(apply concat %) 1656 | (gen/vector g))))))))) 1657 | 1658 | (defn- re-conform [p [x & xs :as data]] 1659 | ;;(prn {:p p :x x :xs xs}) 1660 | (if (empty? data) 1661 | (if (accept-nil? p) 1662 | (let [ret (preturn p)] 1663 | (if (= ret ::nil) 1664 | nil 1665 | ret)) 1666 | ::invalid) 1667 | (if-let [dp (deriv p x)] 1668 | (recur dp xs) 1669 | ::invalid))) 1670 | 1671 | (defn- re-explain [path via in re input] 1672 | (loop [p re [x & xs :as data] input i 0] 1673 | ;;(prn {:p p :x x :xs xs :re re}) (prn) 1674 | (if (empty? data) 1675 | (if (accept-nil? p) 1676 | nil ;;success 1677 | (op-explain (op-describe p) p path via in nil)) 1678 | (if-let [dp (deriv p x)] 1679 | (recur dp xs (inc i)) 1680 | (if (accept? p) 1681 | (if (= (::op p) ::pcat) 1682 | (op-explain (op-describe p) p path via (conj in i) (seq data)) 1683 | [{:path path 1684 | :reason "Extra input" 1685 | :pred (op-describe re) 1686 | :val data 1687 | :via via 1688 | :in (conj in i)}]) 1689 | (c/or (op-explain (op-describe p) p path via (conj in i) (seq data)) 1690 | [{:path path 1691 | :reason "Extra input" 1692 | :pred (op-describe p) 1693 | :val data 1694 | :via via 1695 | :in (conj in i)}])))))) 1696 | 1697 | (defn ^:skip-wiki regex-spec-impl 1698 | "Do not call this directly, use 'spec' with a regex op argument" 1699 | [re gfn] 1700 | (reify 1701 | Specize 1702 | (specize* [s] s) 1703 | (specize* [s _] s) 1704 | 1705 | Spec 1706 | (conform* [_ x] 1707 | (if (c/or (nil? x) (sequential? x)) 1708 | (re-conform re (seq x)) 1709 | ::invalid)) 1710 | (unform* [_ x] (op-unform re x)) 1711 | (explain* [_ path via in x] 1712 | (if (c/or (nil? x) (coll? x)) 1713 | (re-explain path via in re (seq x)) 1714 | [{:path path :pred (res `#(c/or (nil? %) (sequential? %))) :val x :via via :in in}])) 1715 | (gen* [_ overrides path rmap] 1716 | (if gfn 1717 | (gfn) 1718 | (re-gen re overrides path rmap (op-describe re)))) 1719 | (with-gen* [_ gfn] (regex-spec-impl re gfn)) 1720 | (describe* [_] (op-describe re)))) 1721 | 1722 | ;;;;;;;;;;;;;;;;; HOFs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1723 | 1724 | (defn- call-valid? 1725 | [f specs args] 1726 | (let [cargs (conform (:args specs) args)] 1727 | (when-not (invalid? cargs) 1728 | (let [ret (apply f args) 1729 | cret (conform (:ret specs) ret)] 1730 | (c/and (not (invalid? cret)) 1731 | (if (:fn specs) 1732 | (pvalid? (:fn specs) {:args cargs :ret cret}) 1733 | true)))))) 1734 | 1735 | (defn- validate-fn 1736 | "returns f if valid, else smallest" 1737 | [f specs iters] 1738 | (let [g (gen (:args specs)) 1739 | prop (gen/for-all* [g] #(call-valid? f specs %))] 1740 | (let [ret (gen/quick-check iters prop)] 1741 | (if-let [[smallest] (-> ret :shrunk :smallest)] 1742 | smallest 1743 | f)))) 1744 | 1745 | (defn ^:skip-wiki fspec-impl 1746 | "Do not call this directly, use 'fspec'" 1747 | [argspec aform retspec rform fnspec fform gfn] 1748 | (let [specs {:args argspec :ret retspec :fn fnspec}] 1749 | (reify 1750 | clojure.lang.ILookup 1751 | (valAt [this k] (get specs k)) 1752 | (valAt [_ k not-found] (get specs k not-found)) 1753 | 1754 | Specize 1755 | (specize* [s] s) 1756 | (specize* [s _] s) 1757 | 1758 | Spec 1759 | (conform* [this f] (if argspec 1760 | (if (ifn? f) 1761 | (if (identical? f (validate-fn f specs *fspec-iterations*)) f ::invalid) 1762 | ::invalid) 1763 | (throw (Exception. (str "Can't conform fspec without args spec: " (pr-str (describe this))))))) 1764 | (unform* [_ f] f) 1765 | (explain* [_ path via in f] 1766 | (if (ifn? f) 1767 | (let [args (validate-fn f specs 100)] 1768 | (if (identical? f args) ;;hrm, we might not be able to reproduce 1769 | nil 1770 | (let [ret (try (apply f args) (catch Exception t t))] ;;; Throwable 1771 | (if (instance? Exception ret) ;;; Throwable 1772 | ;; TODO add exception data 1773 | [{:path path :pred '(apply fn) :val args :reason (.Message ^Exception ret) :via via :in in}] ;;; .getMessage ^Throwable 1774 | 1775 | (let [cret (dt retspec ret rform)] 1776 | (if (invalid? cret) 1777 | (explain-1 rform retspec (conj path :ret) via in ret) 1778 | (when fnspec 1779 | (let [cargs (conform argspec args)] 1780 | (explain-1 fform fnspec (conj path :fn) via in {:args cargs :ret cret}))))))))) 1781 | [{:path path :pred 'ifn? :val f :via via :in in}])) 1782 | (gen* [_ overrides _ _] (if gfn 1783 | (gfn) 1784 | (gen/return 1785 | (fn [& args] 1786 | (c/assert (pvalid? argspec args) (with-out-str (explain argspec args))) 1787 | (gen/generate (gen retspec overrides)))))) 1788 | (with-gen* [_ gfn] (fspec-impl argspec aform retspec rform fnspec fform gfn)) 1789 | (describe* [_] `(fspec :args ~aform :ret ~rform :fn ~fform))))) 1790 | 1791 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; non-primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1792 | (clojure.spec.alpha/def ::kvs->map (conformer #(zipmap (map ::k %) (map ::v %)) #(map (fn [[k v]] {::k k ::v v}) %))) 1793 | 1794 | (defmacro keys* 1795 | "takes the same arguments as spec/keys and returns a regex op that matches sequences of key/values, 1796 | converts them into a map, and conforms that map with a corresponding 1797 | spec/keys call: 1798 | 1799 | user=> (s/conform (s/keys :req-un [::a ::c]) {:a 1 :c 2}) 1800 | {:a 1, :c 2} 1801 | user=> (s/conform (s/keys* :req-un [::a ::c]) [:a 1 :c 2]) 1802 | {:a 1, :c 2} 1803 | 1804 | the resulting regex op can be composed into a larger regex: 1805 | 1806 | user=> (s/conform (s/cat :i1 integer? :m (s/keys* :req-un [::a ::c]) :i2 integer?) [42 :a 1 :c 2 :d 4 99]) 1807 | {:i1 42, :m {:a 1, :c 2, :d 4}, :i2 99}" 1808 | [& kspecs] 1809 | `(let [mspec# (keys ~@kspecs)] 1810 | (with-gen (clojure.spec.alpha/& (* (cat ::k keyword? ::v any?)) ::kvs->map mspec#) 1811 | (fn [] (gen/fmap (fn [m#] (apply concat m#)) (gen mspec#)))))) 1812 | 1813 | (defn ^:skip-wiki nonconforming 1814 | "takes a spec and returns a spec that has the same properties except 1815 | 'conform' returns the original (not the conformed) value. Note, will specize regex ops." 1816 | [spec] 1817 | (let [spec (delay (specize spec))] 1818 | (reify 1819 | Specize 1820 | (specize* [s] s) 1821 | (specize* [s _] s) 1822 | 1823 | Spec 1824 | (conform* [_ x] (let [ret (conform* @spec x)] 1825 | (if (invalid? ret) 1826 | ::invalid 1827 | x))) 1828 | (unform* [_ x] x) 1829 | (explain* [_ path via in x] (explain* @spec path via in x)) 1830 | (gen* [_ overrides path rmap] (gen* @spec overrides path rmap)) 1831 | (with-gen* [_ gfn] (nonconforming (with-gen* @spec gfn))) 1832 | (describe* [_] `(nonconforming ~(describe* @spec)))))) 1833 | 1834 | (defn ^:skip-wiki nilable-impl 1835 | "Do not call this directly, use 'nilable'" 1836 | [form pred gfn] 1837 | (let [spec (delay (specize pred form))] 1838 | (reify 1839 | Specize 1840 | (specize* [s] s) 1841 | (specize* [s _] s) 1842 | 1843 | Spec 1844 | (conform* [_ x] (if (nil? x) nil (conform* @spec x))) 1845 | (unform* [_ x] (if (nil? x) nil (unform* @spec x))) 1846 | (explain* [_ path via in x] 1847 | (when-not (c/or (pvalid? @spec x) (nil? x)) 1848 | (conj 1849 | (explain-1 form pred (conj path ::pred) via in x) 1850 | {:path (conj path ::nil) :pred 'nil? :val x :via via :in in}))) 1851 | (gen* [_ overrides path rmap] 1852 | (if gfn 1853 | (gfn) 1854 | (gen/frequency 1855 | [[1 (gen/delay (gen/return nil))] 1856 | [9 (gen/delay (gensub pred overrides (conj path ::pred) rmap form))]]))) 1857 | (with-gen* [_ gfn] (nilable-impl form pred gfn)) 1858 | (describe* [_] `(nilable ~(res form)))))) 1859 | 1860 | (defmacro nilable 1861 | "returns a spec that accepts nil and values satisfying pred" 1862 | [pred] 1863 | (let [pf (res pred)] 1864 | `(nilable-impl '~pf ~pred nil))) 1865 | 1866 | (defn exercise 1867 | "generates a number (default 10) of values compatible with spec and maps conform over them, 1868 | returning a sequence of [val conformed-val] tuples. Optionally takes 1869 | a generator overrides map as per gen" 1870 | ([spec] (exercise spec 10)) 1871 | ([spec n] (exercise spec n nil)) 1872 | ([spec n overrides] 1873 | (map #(vector % (conform spec %)) (gen/sample (gen spec overrides) n)))) 1874 | 1875 | (defn exercise-fn 1876 | "exercises the fn named by sym (a symbol) by applying it to 1877 | n (default 10) generated samples of its args spec. When fspec is 1878 | supplied its arg spec is used, and sym-or-f can be a fn. Returns a 1879 | sequence of tuples of [args ret]. " 1880 | ([sym] (exercise-fn sym 10)) 1881 | ([sym n] (exercise-fn sym n (get-spec sym))) 1882 | ([sym-or-f n fspec] 1883 | (let [f (if (symbol? sym-or-f) (resolve sym-or-f) sym-or-f)] 1884 | (if-let [arg-spec (c/and fspec (:args fspec))] 1885 | (for [args (gen/sample (gen arg-spec) n)] 1886 | [args (apply f args)]) 1887 | (throw (Exception. "No :args spec found, can't generate")))))) 1888 | 1889 | (defn inst-in-range? 1890 | "Return true if inst at or after start and before end" 1891 | [start end inst] 1892 | (c/and (inst? inst) 1893 | (let [t (inst-ms inst)] 1894 | (c/and (<= (inst-ms start) t) (< t (inst-ms end)))))) 1895 | 1896 | (defmacro inst-in 1897 | "Returns a spec that validates insts in the range from start 1898 | (inclusive) to end (exclusive)." 1899 | [start end] 1900 | `(let [st# (inst-ms ~start) 1901 | et# (inst-ms ~end) 1902 | mkdate# (fn [d#] (System.DateTime. ^{:tag ~'long} d#))] ;;; java.util.Date. 1903 | (spec (and inst? #(inst-in-range? ~start ~end %)) 1904 | :gen (fn [] 1905 | (gen/fmap mkdate# 1906 | (gen/large-integer* {:min st# :max et#})))))) 1907 | 1908 | (defn int-in-range? 1909 | "Return true if start <= val, val < end and val is a fixed 1910 | precision integer." 1911 | [start end val] 1912 | (c/and (int? val) (<= start val) (< val end))) 1913 | 1914 | (defmacro int-in 1915 | "Returns a spec that validates fixed precision integers in the 1916 | range from start (inclusive) to end (exclusive)." 1917 | [start end] 1918 | `(spec (and int? #(int-in-range? ~start ~end %)) 1919 | :gen #(gen/large-integer* {:min ~start :max (dec ~end)}))) 1920 | 1921 | (defmacro double-in 1922 | "Specs a 64-bit floating point number. Options: 1923 | 1924 | :infinite? - whether +/- infinity allowed (default true) 1925 | :NaN? - whether NaN allowed (default true) 1926 | :min - minimum value (inclusive, default none) 1927 | :max - maximum value (inclusive, default none)" 1928 | [& {:keys [infinite? NaN? min max] 1929 | :or {infinite? true NaN? true} 1930 | :as m}] 1931 | `(spec (and c/double? 1932 | ~@(when-not infinite? '[#(not (Double/IsInfinity %))]) ;;; Double/isInfinite 1933 | ~@(when-not NaN? '[#(not (Double/IsNaN %))]) ;;; Double/isNaN 1934 | ~@(when max `[#(<= % ~max)]) 1935 | ~@(when min `[#(<= ~min %)])) 1936 | :gen #(gen/double* ~m))) 1937 | 1938 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; assert ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1939 | (defonce 1940 | ^{:dynamic true 1941 | :doc "If true, compiler will enable spec asserts, which are then 1942 | subject to runtime control via check-asserts? If false, compiler 1943 | will eliminate all spec assert overhead. See 'assert'. 1944 | 1945 | Initially set to boolean value of clojure.spec.compile-asserts 1946 | system property. Defaults to true."} 1947 | *compile-asserts* 1948 | (not= "false" (Environment/GetEnvironmentVariable "clojure.spec.compile-asserts"))) ;;; System/getProperty 1949 | 1950 | (defn check-asserts? 1951 | "Returns the value set by check-asserts." 1952 | [] 1953 | clojure.lang.RT/checkSpecAsserts) 1954 | 1955 | (defn check-asserts 1956 | "Enable or disable spec asserts that have been compiled 1957 | with '*compile-asserts*' true. See 'assert'. 1958 | 1959 | Initially set to boolean value of clojure.spec.check-asserts 1960 | system property. Defaults to false." 1961 | [flag] 1962 | (set! (. clojure.lang.RT checkSpecAsserts) flag)) 1963 | 1964 | (defn assert* 1965 | "Do not call this directly, use 'assert'." 1966 | [spec x] 1967 | (if (valid? spec x) 1968 | x 1969 | (let [ed (c/merge (assoc (explain-data* spec [] [] [] x) 1970 | ::failure :assertion-failed))] 1971 | (throw (ex-info 1972 | (str "Spec assertion failed\n" (with-out-str (explain-out ed))) 1973 | ed))))) 1974 | 1975 | (defmacro assert 1976 | "spec-checking assert expression. Returns x if x is valid? according 1977 | to spec, else throws an ex-info with explain-data plus ::failure of 1978 | :assertion-failed. 1979 | 1980 | Can be disabled at either compile time or runtime: 1981 | 1982 | If *compile-asserts* is false at compile time, compiles to x. Defaults 1983 | to value of 'clojure.spec.compile-asserts' system property, or true if 1984 | not set. 1985 | 1986 | If (check-asserts?) is false at runtime, always returns x. Defaults to 1987 | value of 'clojure.spec.check-asserts' system property, or false if not 1988 | set. You can toggle check-asserts? with (check-asserts bool)." 1989 | [spec x] 1990 | (if *compile-asserts* 1991 | `(if clojure.lang.RT/checkSpecAsserts 1992 | (assert* ~spec ~x) 1993 | ~x) 1994 | x)) 1995 | --------------------------------------------------------------------------------