├── VERSION_TEMPLATE
├── .gitignore
├── deps.edn
├── .github
    ├── workflows
    │   ├── snapshot.yml
    │   ├── release.yml
    │   └── test.yml
    └── PULL_REQUEST_TEMPLATE
├── script
    └── build
    │   ├── update_version
    │   ├── git_revision
    │   ├── branch_revision
    │   ├── trunk_revision
    │   └── revision
├── CONTRIBUTING.md
├── src
    ├── main
    │   └── clojure
    │   │   └── clojure
    │   │       └── alpha
    │   │           ├── spec
    │   │               ├── protocols.clj
    │   │               ├── gen.clj
    │   │               ├── test.clj
    │   │               └── impl.clj
    │   │           └── spec.clj
    └── test
    │   └── clojure
    │       └── clojure
    │           └── test_clojure
    │               ├── multi_spec.clj
    │               ├── instr.clj
    │               └── spec.clj
├── README.md
├── CHANGES.md
├── pom.xml
├── LICENSE
└── epl-v10.html


/VERSION_TEMPLATE:
--------------------------------------------------------------------------------
1 | 0.2.GENERATED_VERSION
2 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
1 | .idea
2 | *.jar
3 | *.iml
4 | /target/
5 | .lein*
6 | .nrepl-port
7 | .cpcache
8 | 


--------------------------------------------------------------------------------
/deps.edn:
--------------------------------------------------------------------------------
1 | {:paths ["src/main/clojure"]
2 |  :deps {org.clojure/clojure {:mvn/version "1.10.1"}}
3 |  :aliases
4 |  {:test
5 |   {:extra-deps
6 |    {org.clojure/test.check {:mvn/version "1.1.0"}}}}}
7 | 
8 | 


--------------------------------------------------------------------------------
/.github/workflows/snapshot.yml:
--------------------------------------------------------------------------------
1 | name: Snapshot on demand
2 | 
3 | on: [workflow_dispatch]
4 | 
5 | jobs:
6 |   call-snapshot:
7 |     uses: clojure/build.ci/.github/workflows/snapshot.yml@master
8 |     secrets: inherit
9 | 


--------------------------------------------------------------------------------
/script/build/update_version:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env bash
2 | 
3 | set -e
4 | 
5 | mvn versions:set -DgenerateBackupPoms=false -DnewVersion=`script/build/revision`-SNAPSHOT
6 | git commit -m 'update version' pom.xml
7 | git push
8 | 


--------------------------------------------------------------------------------
/script/build/git_revision:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | # Return the portion of the version number generated from git
 4 | # <trunk-basis>
 5 | 
 6 | set -e
 7 | 
 8 | trunk_basis=`script/build/trunk_revision`
 9 | sha=`git rev-parse HEAD`
10 | 
11 | sha=${sha:0:${#sha}-34} # drop the last 34 characters, keep 6
12 | 
13 | echo $trunk_basis
14 | 


--------------------------------------------------------------------------------
/script/build/branch_revision:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | # If on a branch other than master, returns the number of commits made off of master
 4 | # If on master, returns 0
 5 | 
 6 | set -e
 7 | 
 8 | master_tag=`git rev-parse --abbrev-ref HEAD`
 9 | 
10 | if [ "$master_tag" == "master" ]; then
11 |     echo "0"
12 | else
13 |     last_commit=`git rev-parse HEAD`
14 |     revision=`git rev-list master..$last_commit | wc -l`
15 |     echo $revision
16 | fi
17 | 


--------------------------------------------------------------------------------
/script/build/trunk_revision:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | # Returns the number of commits made since the v0.0 tag
 4 | 
 5 | set -e
 6 | 
 7 | REVISION=`git --no-replace-objects describe --match v0.0`
 8 | 
 9 | # Extract the version number from the string. Do this in two steps so
10 | # it is a little easier to understand.
11 | REVISION=${REVISION:5} # drop the first 5 characters
12 | REVISION=${REVISION:0:${#REVISION}-9} # drop the last 9 characters
13 | 
14 | echo $REVISION
15 | 


--------------------------------------------------------------------------------
/CONTRIBUTING.md:
--------------------------------------------------------------------------------
 1 | This is a [Clojure contrib] project.
 2 | 
 3 | Under the Clojure contrib [guidelines], this project cannot accept
 4 | pull requests. All patches must be submitted via [JIRA].
 5 | 
 6 | See [Contributing] on the Clojure website for
 7 | more information on how to contribute.
 8 | 
 9 | [Clojure contrib]: https://clojure.org/community/contrib_libs
10 | [Contributing]: https://clojure.org/community/contributing
11 | [JIRA]: https://clojure.atlassian.net/browse/CLJ
12 | [guidelines]: https://clojure.org/community/contrib_howto
13 | 


--------------------------------------------------------------------------------
/script/build/revision:
--------------------------------------------------------------------------------
 1 | #!/usr/bin/env bash
 2 | 
 3 | # Return the complete revision number
 4 | # <major>.<minor>.<trunk-basis>.<patch-or-0>-<sha>[-qualifier]
 5 | 
 6 | set -e
 7 | 
 8 | version_template=`cat VERSION_TEMPLATE`
 9 | 
10 | if [[ "$version_template" =~ ^[0-9]+\.[0-9]+\.GENERATED_VERSION(-[a-zA-Z0-9]+)?$ ]]; then
11 | 
12 |     git_revision=`script/build/git_revision`
13 |     echo ${version_template/GENERATED_VERSION/$git_revision}
14 | 
15 | else
16 |     echo "Invalid version template string: $version_template" >&2
17 |     exit -1
18 | fi
19 | 
20 | 


--------------------------------------------------------------------------------
/.github/workflows/release.yml:
--------------------------------------------------------------------------------
 1 | name: Release on demand
 2 | 
 3 | on:
 4 |   workflow_dispatch:
 5 |     inputs:
 6 |       releaseVersion:
 7 |         description: "Version to release"
 8 |         required: true
 9 |       snapshotVersion:
10 |         description: "Snapshot version after release"
11 |         required: true
12 | 
13 | jobs:
14 |   call-release:
15 |     uses: clojure/build.ci/.github/workflows/release.yml@master
16 |     with:
17 |       releaseVersion: ${{ github.event.inputs.releaseVersion }}
18 |       snapshotVersion: ${{ github.event.inputs.snapshotVersion }}
19 |     secrets: inherit


--------------------------------------------------------------------------------
/.github/workflows/test.yml:
--------------------------------------------------------------------------------
 1 | name: Test
 2 | 
 3 | on: [push]
 4 | 
 5 | jobs:
 6 |   test:
 7 |     strategy:
 8 |       matrix:
 9 |         os: [ubuntu-latest] # macOS-latest, windows-latest]
10 |         java-version: ["8", "11", "17"]
11 |         clojure-version: ["1.10.3", "1.11.1"]
12 |     runs-on: ${{ matrix.os }}
13 |     steps:
14 |     - uses: actions/checkout@v3
15 |     - name: Set up Java
16 |       uses: actions/setup-java@v3
17 |       with:
18 |         java-version: ${{ matrix.java-version }}
19 |         distribution: 'temurin'
20 |         cache: 'maven'
21 |     - name: Build with Maven
22 |       run: mvn -ntp -B -Dclojure.version=${{ matrix.clojure-version }} clean test
23 | 


--------------------------------------------------------------------------------
/.github/PULL_REQUEST_TEMPLATE:
--------------------------------------------------------------------------------
 1 | Hi! Thanks for your interest in contributing to this project.
 2 | 
 3 | Clojure contrib projects do not use GitHub issues or pull requests, and
 4 | require a signed Contributor Agreement. If you would like to contribute,
 5 | please read more about the CA and sign that first (this can be done online).
 6 | 
 7 | Then go to this project's issue tracker in JIRA to create tickets, update
 8 | tickets, or submit patches. For help in creating tickets and patches,
 9 | please see:
10 | 
11 | - Signing the CA: https://clojure.org/community/contributing
12 | - Creating Tickets: https://clojure.org/community/creating_tickets
13 | - Developing Patches: https://clojure.org/community/developing_patches
14 | - Contributing FAQ: https://clojure.org/community/contributing
15 | 


--------------------------------------------------------------------------------
/src/main/clojure/clojure/alpha/spec/protocols.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.alpha.spec.protocols)
10 | 
11 | (defprotocol Spec
12 |   :extend-via-metadata true
13 |   (conform* [spec x settings-key settings])
14 |   (unform* [spec y])
15 |   (explain* [spec path via in x settings-key settings])
16 |   (gen* [spec overrides path rmap])
17 |   (with-gen* [spec gfn])
18 |   (describe* [spec]))
19 | 
20 | (defprotocol Schema
21 |   (keyspecs* [spec] "Returns map of key to symbolic spec"))
22 | 
23 | (defprotocol Select
24 |   "Marker protocol for selects")
25 | 
26 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | alpha.spec
 2 | ========================================
 3 | 
 4 | spec is a Clojure library to describe the structure of data and functions. Specs can be used to validate data, conform (destructure) data, explain invalid data, generate examples that conform to the specs, and automatically use generative testing to test functions.
 5 | 
 6 | For more information:
 7 | 
 8 | * Rationale - https://clojure.org/about/spec
 9 | * Guide - https://clojure.org/guides/spec (for spec.alpha, note namespaces and other differences below)
10 | 
11 | spec.alpha was released with Clojure 1.9 and can be found at https://github.com/clojure/spec.alpha. This library is an evolution from spec.alpha as well as work towards several new features. Please note that alpha.spec is not 100% API-compatible with spec.alpha (although it is similar).
12 | 
13 | Namespaces to load:
14 | 
15 |     (require '[clojure.alpha.spec :as s]
16 |              '[clojure.alpha.spec.gen :as gen]
17 |              '[clojure.alpha.spec.test :as test])
18 | 
19 | Also see: [Differences from spec.alpha](https://github.com/clojure/spec-alpha2/wiki/Differences-from-spec.alpha)
20 | 
21 | 
22 | Releases and Dependency Information
23 | ========================================
24 | 
25 | This library is a work in progress provided to gather feedback during development. Namespaces, apis, etc may change without warning. The HEAD may not always be stable (although it usually is).
26 | 
27 | During development, you can use the git dep to try alpha.spec:
28 | 
29 |     clj -Sdeps '{:deps {org.clojure/clojure {:mvn/version "1.10.1"}
30 |                         org.clojure/test.check {:mvn/version "0.9.0"} 
31 |                         org.clojure/alpha.spec {:git/url "https://github.com/clojure/spec-alpha2.git" 
32 |                                                 :sha "<SHA>"}}}'
33 | 
34 | Where the latest SHA can be found with:
35 | 
36 |     git ls-remote https://github.com/clojure/spec-alpha2.git refs/heads/master
37 | 
38 | When we believe this library is ready for use, we will begin publishing releases to Maven central.
39 | 
40 | Developer Information
41 | ========================================
42 | 
43 | * [API docs](https://clojure.github.io/spec-alpha2/)
44 | * [GitHub project](https://github.com/clojure/spec-alpha2)
45 | * [Changelog](https://github.com/clojure/spec-alpha2/blob/master/CHANGES.md)
46 | * [Bug Tracker](https://clojure.atlassian.net/browse/CLJ)
47 | * [Continuous Integration](https://github.com/clojure/spec-alpha2/actions/workflows/test.yml)
48 | 
49 | Copyright and License
50 | ========================================
51 | 
52 | Copyright (c) Rich Hickey, and contributors, 2018-2023. All rights reserved.  The use and distribution terms for this software are covered by the Eclipse Public License 1.0 (https://opensource.org/licenses/eclipse-1.0.php) which can be found in the file epl-v10.html at the root of this distribution. By using this software in any fashion, you are agreeing to be bound bythe terms of this license.  You must not remove this notice, or any other, from this software.
53 | 


--------------------------------------------------------------------------------
/src/test/clojure/clojure/test_clojure/multi_spec.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.multi-spec
10 |   (:require [clojure.spec.alpha :as s]
11 |             [clojure.test :as test :refer [deftest is testing]]
12 |             [clojure.test-clojure.spec :refer [submap?]]))
13 | 
14 | (s/def :event/type keyword?)
15 | (s/def :event/timestamp int?)
16 | (s/def :search/url string?)
17 | (s/def :error/message string?)
18 | (s/def :error/code int?)
19 | 
20 | (defmulti event-type :event/type)
21 | (defmethod event-type :event/search [_]
22 |   (s/keys :req [:event/type :event/timestamp :search/url]))
23 | (defmethod event-type :event/error [_]
24 |   (s/keys :req [:event/type :event/timestamp :error/message :error/code]))
25 | 
26 | (s/def :event/event (s/multi-spec event-type :event/type))
27 | 
28 | (deftest multi-spec-test
29 |   (is (s/valid? :event/event
30 |         {:event/type :event/search
31 |          :event/timestamp 1463970123000
32 |          :search/url "https://clojure.org"}))
33 |   (is (s/valid? :event/event
34 |         {:event/type :event/error
35 |          :event/timestamp 1463970123000
36 |          :error/message "Invalid host"
37 |          :error/code 500}))
38 |   (is (submap?
39 |         '#:clojure.spec.alpha{:problems
40 |                               [{:path [:event/restart],
41 |                                 :pred clojure.test-clojure.multi-spec/event-type,
42 |                                 :val #:event{:type :event/restart}, :reason "no method", :via [:event/event], :in []}],
43 |                               :spec :event/event, :value #:event{:type :event/restart}}
44 |         (s/explain-data :event/event
45 |           {:event/type :event/restart})))
46 |   (is (submap?
47 |         '#:clojure.spec.alpha{:problems ({:path [:event/search],
48 |                                           :pred (clojure.core/fn [%] (clojure.core/contains? % :event/timestamp)),
49 |                                           :val {:event/type :event/search, :search/url 200},
50 |                                           :via [:event/event], :in []} {:path [:event/search :search/url],
51 |                                                                         :pred clojure.core/string?, :val 200,
52 |                                                                         :via [:event/event :search/url],
53 |                                                                         :in [:search/url]}), :spec
54 |                               :event/event, :value {:event/type :event/search, :search/url 200}}
55 |         (s/explain-data  :event/event
56 |           {:event/type :event/search
57 |            :search/url 200}))))


--------------------------------------------------------------------------------
/CHANGES.md:
--------------------------------------------------------------------------------
 1 | # Change Log for spec-alpha2
 2 | 
 3 | ## FORKED from spec.alpha on Oct 22, 2018
 4 | 
 5 | ## Version 0.2.176 on Sept 4, 2018
 6 | 
 7 | * [CLJ-2373](https://clojure.atlassian.net/browse/CLJ-2373) Don't print ex-info into spec errors
 8 | * [CLJ-2391](https://clojure.atlassian.net/browse/CLJ-2391) Change spec problem line print order
 9 | * [CLJ-2392](https://clojure.atlassian.net/browse/CLJ-2392) Stop prepending :args to spec problem paths
10 | * [CLJ-2393](https://clojure.atlassian.net/browse/CLJ-2393) Sort on descending "in" length before "at" length
11 | 
12 | ## Version 0.2.168 on June 26, 2018
13 | 
14 | * [CLJ-2182](https://clojure.atlassian.net/browse/CLJ-2182) Always check preds for s/& on nil input
15 | * [CLJ-2178](https://clojure.atlassian.net/browse/CLJ-2178) Return resolved pred for s/& explain-data
16 | * [CLJ-2177](https://clojure.atlassian.net/browse/CLJ-2177) Return valid resolved pred in s/keys explain-data
17 | * [CLJ-2167](https://clojure.atlassian.net/browse/CLJ-2176) Properly check for int? in int-in-range?
18 | * [CLJ-2166](https://clojure.atlassian.net/browse/CLJ-2166) added function name to instrument exception map
19 | * [CLJ-2111](https://clojure.atlassian.net/browse/CLJ-2111) Clarify docstring for :kind in s/every
20 | * [CLJ-2068](https://clojure.atlassian.net/browse/CLJ-2068) Capture form of set and function instances in spec
21 | * [CLJ-2060](https://clojure.atlassian.net/browse/CLJ-2060) Remove a spec by s/def of nil
22 | * [CLJ-2046](https://clojure.atlassian.net/browse/CLJ-2046) gen random subsets of or'd req keys in map specs
23 | * [CLJ-2026](https://clojure.atlassian.net/browse/CLJ-2026) Prevent concurrent loads in dynaload
24 | * [CLJ-2176](https://clojure.atlassian.net/browse/CLJ-2176) s/tuple explain-data :pred problem
25 | 
26 | ## Version 0.1.143 on Oct 30, 2017
27 | 
28 | * [CLJ-2259](https://clojure.atlassian.net/browse/CLJ-2259) - map decimal? to big decimal generator (instead of bigdec?)
29 | 
30 | ## Version 0.1.134 on Oct 6, 2017
31 | 
32 | * [CLJ-2103](https://clojure.atlassian.net/browse/CLJ-2103) - s/coll-of and s/every gen is very slow if :kind specified without :into
33 | * [CLJ-2171](https://clojure.atlassian.net/browse/CLJ-2171) - Default explain printer shouldn't print root val and spec
34 | * Mark Clojure dependency as a provided dep so it's not transitively included
35 | 
36 | ## Version 0.1.123 on May 26, 2017
37 | 
38 | * No changes, just a rebuild
39 | 
40 | ## Version 0.1.109 on May 26, 2017
41 | 
42 | * [CLJ-2153](https://clojure.atlassian.net/browse/CLJ-2153) - Docstring for int-in-range? and int-in now mention fixed precision constraint
43 | * [CLJ-2085](https://clojure.atlassian.net/browse/CLJ-2085) - Add the top level spec and value to explain-data
44 | * [CLJ-2076](https://clojure.atlassian.net/browse/CLJ-2076) - coll-of and map-of should unform their elements
45 | * [CLJ-2063](https://clojure.atlassian.net/browse/CLJ-2063) - report explain errors in order from longest to shortest path
46 | * [CLJ-2061](https://clojure.atlassian.net/browse/CLJ-2061) - Better error message when exercise-fn called on fn without :args spec
47 | * [CLJ-2059](https://clojure.atlassian.net/browse/CLJ-2059) - explain-data should return resolved preds
48 | * [CLJ-2057](https://clojure.atlassian.net/browse/CLJ-2057) - If :ret spec is not supplied, use any?
49 | 
50 | ## Version 0.1.108 on May 2, 2017
51 | 
52 | * AOT compile the spec namespaces
53 | 
54 | ## Version 0.1.94 on Apr 26, 2017
55 | 
56 | * Moved spec namespaces from Clojure
57 | * Renamed spec namespaces to append ".alpha"
58 | 
59 | 


--------------------------------------------------------------------------------
/pom.xml:
--------------------------------------------------------------------------------
  1 | <?xml version="1.0" encoding="UTF-8"?>
  2 | <project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/xsd/maven-4.0.0.xsd">
  3 |   <modelVersion>4.0.0</modelVersion>
  4 |   <artifactId>alpha.spec</artifactId>
  5 |   <version>0.2.177-SNAPSHOT</version>
  6 |   <name>alpha.spec</name>
  7 |   <description>Specification of data and functions</description>
  8 | 
  9 |   <scm>
 10 |     <connection>scm:git:git://github.com/clojure/spec-alpha2.git</connection>
 11 |     <developerConnection>scm:git:ssh://git@github.com/clojure/spec-alpha2.git</developerConnection>
 12 |     <tag>HEAD</tag>
 13 |     <url>https://github.com/clojure/spec-alpha2</url>
 14 |   </scm>
 15 | 
 16 |   <licenses>
 17 |     <license>
 18 |       <name>Eclipse Public License 1.0</name>
 19 |       <url>http://opensource.org/licenses/eclipse-1.0.php</url>
 20 |       <distribution>repo</distribution>
 21 |     </license>
 22 |   </licenses>
 23 | 
 24 |   <parent>
 25 |     <groupId>org.clojure</groupId>
 26 |     <artifactId>pom.contrib</artifactId>
 27 |     <version>1.3.0</version>
 28 |   </parent>
 29 | 
 30 |   <developers>
 31 |     <developer>
 32 |       <id>richhickey</id>
 33 |       <name>Rich Hickey</name>
 34 |       <url>http://clojure.org</url>
 35 |     </developer>
 36 |   </developers>
 37 | 
 38 |   <properties>
 39 |     <clojure.version>1.12.0</clojure.version>
 40 |   </properties>
 41 | 
 42 |   <dependencies>
 43 |     <dependency>
 44 |       <groupId>org.clojure</groupId>
 45 |       <artifactId>clojure</artifactId>
 46 |       <version>${clojure.version}</version>
 47 |       <scope>provided</scope>
 48 |     </dependency>
 49 |     <dependency>
 50 |       <groupId>org.clojure</groupId>
 51 |       <artifactId>test.check</artifactId>
 52 |       <version>1.0.0</version>
 53 |       <scope>test</scope>
 54 |     </dependency>
 55 |   </dependencies>
 56 | 
 57 |   <build>
 58 |     <plugins>
 59 |       <plugin>
 60 |         <groupId>org.codehaus.mojo</groupId>
 61 |         <artifactId>exec-maven-plugin</artifactId>
 62 | 	<version>1.6.0</version>
 63 | 	<executions>
 64 |           <execution>
 65 |             <id>compile-clojure</id>
 66 |             <phase>compile</phase>
 67 |             <goals><goal>exec</goal></goals>
 68 |             <configuration>
 69 |               <executable>java</executable>
 70 |               <classpathScope>compile</classpathScope>
 71 |                 <arguments>
 72 |                 <argument>-Dclojure.compile.path=${project.build.directory}/classes</argument>
 73 |                 <argument>-Dclojure.spec.skip-macros=true</argument>
 74 |                 <argument>-classpath</argument>
 75 |                 <classpath />
 76 |                 <argument>clojure.lang.Compile</argument>
 77 |                 <argument>clojure.alpha.spec.protocols</argument>
 78 |                 <argument>clojure.alpha.spec</argument>
 79 |                 <argument>clojure.alpha.spec.impl</argument>
 80 |                 <argument>clojure.alpha.spec.gen</argument>
 81 |                 <argument>clojure.alpha.spec.test</argument>
 82 |               </arguments>
 83 |             </configuration>
 84 |           </execution>
 85 |         </executions>
 86 |       </plugin>
 87 |       <plugin>
 88 |         <groupId>com.theoryinpractise</groupId>
 89 |         <artifactId>clojure-maven-plugin</artifactId>
 90 |         <version>1.7.1</version>
 91 |         <executions>
 92 |           <execution>
 93 |             <id>clojure-compile</id>
 94 |             <phase>none</phase>
 95 |           </execution>
 96 |           <execution>
 97 |             <id>clojure-test</id>
 98 |             <phase>test</phase>
 99 |           </execution>
100 |         </executions>
101 | 	<configuration>
102 |           <sourceDirectories>
103 |             <sourceDirectory>src/main/clojure</sourceDirectory>
104 |           </sourceDirectories>
105 |           <testSourceDirectories>
106 |             <testSourceDirectory>src/test/clojure</testSourceDirectory>
107 |           </testSourceDirectories>
108 |         </configuration>
109 |       </plugin>
110 |     </plugins>
111 |   </build>
112 | </project>
113 | 


--------------------------------------------------------------------------------
/src/test/clojure/clojure/test_clojure/instr.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.instr
 10 |   (:require
 11 |    [clojure.pprint :as pp]
 12 |    [clojure.alpha.spec :as s]
 13 |    [clojure.alpha.spec.gen :as gen]
 14 |    [clojure.alpha.spec.test :as stest]
 15 |    [clojure.test :refer :all]))
 16 | 
 17 | (set! *warn-on-reflection* true)
 18 | 
 19 | ;; utils
 20 | 
 21 | (defmacro with-feature [feature & body]
 22 |   `(try ~feature
 23 |      ~@body
 24 |      (catch Exception ex#)))
 25 | 
 26 | ;; instrument tests
 27 | 
 28 | (defn kwargs-fn
 29 |   ([opts] opts)
 30 |   ([a b] [a b])
 31 |   ([a b & {:as m}] [a b m]))
 32 | 
 33 | (defn no-kwargs-fn
 34 |   ([opts] opts)
 35 |   ([a b] [a b])
 36 |   ([args inner & opts] [args inner opts]))
 37 | 
 38 | (defn no-kwargs-destruct-fn
 39 |   ([opts] opts)
 40 |   ([{:as a} b] [a b])
 41 |   ([{:as args} inner & opts] [args inner opts]))
 42 | 
 43 | (defn just-varargs [& args]
 44 |   (apply + args))
 45 | 
 46 | (defn add10 [n]
 47 |   (+ 10 n))
 48 | 
 49 | (alter-meta! #'add10 dissoc :arglists)
 50 | 
 51 | ;;; Specs
 52 | 
 53 | (s/def ::a any?)
 54 | (s/def ::b number?)
 55 | (s/def ::c any?)
 56 | (s/def ::m map?)
 57 | 
 58 | (s/fdef kwargs-fn
 59 |   :args (s/alt :unary  (s/cat :a ::a)
 60 |                :binary (s/cat :a ::a :b ::b)
 61 |                :variadic (s/cat :a ::a
 62 |                                 :b ::b
 63 |                                 :kwargs (s/keys* :opt-un [::a ::b ::c]))))
 64 | 
 65 | (s/fdef no-kwargs-fn
 66 |   :args (s/alt :unary  (s/cat :a ::a)
 67 |                :binary (s/cat :a ::a :b ::b)
 68 |                :variadic (s/cat :a ::a
 69 |                                 :b ::b
 70 |                                 :varargs (s/cat :numbers (s/* number?)))))
 71 | 
 72 | (s/fdef no-kwargs-destruct-fn
 73 |   :args (s/alt :unary  (s/cat :a ::a)
 74 |                :binary (s/cat :a ::a :m ::m)
 75 |                :variadic (s/cat :a ::a
 76 |                                 :b ::b
 77 |                                 :varargs (s/cat :numbers (s/* number?)))))
 78 | 
 79 | (s/fdef just-varargs
 80 |   :args (s/cat :numbers (s/* number?))
 81 |   :ret number?)
 82 | 
 83 | (s/fdef add10
 84 |   :args (s/cat :arg ::b)
 85 |   :ret number?)
 86 | 
 87 | (defn- fail-no-kwargs [& args] (apply no-kwargs-fn args))
 88 | (defn- fail-kwargs [& args] (apply kwargs-fn args))
 89 | 
 90 | (with-feature (kwargs-fn 1 2 {:a 1 :b 2})
 91 |   (deftest test-instrument
 92 |     (testing "that a function taking fixed args and varargs is spec'd and checked at runtime"
 93 |       (letfn [(test-varargs-raw []
 94 |                 (are [x y] (= x y)
 95 |                   1                         (no-kwargs-fn 1)
 96 |                   [1 2]                     (no-kwargs-fn 1 2)
 97 |                   [1 2 [3 4 5]]             (no-kwargs-fn 1 2 3 4 5)))]
 98 |         (testing "that the raw kwargs function operates as expected"
 99 |           (test-varargs-raw))
100 | 
101 |         (testing "that the instrumented kwargs function operates as expected"
102 |           (stest/instrument `no-kwargs-fn {})
103 | 
104 |           (test-varargs-raw)
105 |           (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (no-kwargs-fn 1 :not-num)))
106 |           (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (no-kwargs-fn 1 2 :not-num 3)))
107 | 
108 |           (testing "that the ex-info data looks correct"
109 |             (try (fail-no-kwargs 1 :not-num)
110 |                  (catch Exception ei
111 |                    (is (= 'clojure.test-clojure.instr/fail-no-kwargs (-> ei ex-data :clojure.alpha.spec.test/caller :var-scope)))))
112 | 
113 |             (try (fail-no-kwargs 1 2 :not-num 3)
114 |                  (catch Exception ei
115 |                    (is (= 'clojure.test-clojure.instr/fail-no-kwargs (-> ei ex-data :clojure.alpha.spec.test/caller :var-scope)))))))
116 | 
117 |         (testing "that the uninstrumented kwargs function operates as the raw function"
118 |           (stest/unstrument `no-kwargs-fn)
119 |           (test-varargs-raw))))
120 | 
121 |     (testing "that a function taking only varargs is spec'd and checked at runtime"
122 |       (letfn [(test-varargs-raw []
123 |                 (are [x y] (= x y)
124 |                   1                         (just-varargs 1)
125 |                   3                         (just-varargs 1 2)
126 |                   15                        (just-varargs 1 2 3 4 5)))]
127 |         (testing "that the raw varargs function operates as expected"
128 |           (test-varargs-raw))
129 | 
130 |         (testing "that the instrumented varargs function operates as expected"
131 |           (stest/instrument `just-varargs {})
132 | 
133 |           (test-varargs-raw)
134 |           (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (just-varargs 1 :not-num)))
135 |           (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (just-varargs 1 2 :not-num 3))))
136 | 
137 |         (testing "that the uninstrumented kwargs function operates as the raw function"
138 |           (stest/unstrument `just-varargs)
139 |           (test-varargs-raw))))
140 | 
141 |     (testing "that a function taking keyword args is spec'd and checked at runtime"
142 |       (letfn [(test-kwargs-baseline []
143 |                 (are [x y] (= x y)
144 |                   1                         (kwargs-fn 1)
145 |                   [1 2]                     (kwargs-fn 1 2)
146 |                   [1 2 {:a 1}]              (kwargs-fn 1 2 :a 1)
147 |                   [1 2 {:a 1}]              (kwargs-fn 1 2 {:a 1})
148 |                   [1 2 {:a 1 :b 2}]         (kwargs-fn 1 2 :a 1 {:b 2})))
149 |               (test-kwargs-extended []
150 |                 (are [x y] (= x y)
151 |                   [1 :not-num]              (kwargs-fn 1 :not-num)
152 |                   [1 2 {:a 1 :b :not-num}]  (kwargs-fn 1 2 :a 1 {:b :not-num})))]
153 |         (testing "that the raw kwargs function operates as expected"
154 |           (test-kwargs-baseline)
155 |           (test-kwargs-extended))
156 | 
157 |         (testing "that the instrumented kwargs function operates as expected"
158 |           (stest/instrument `kwargs-fn {})
159 | 
160 |           (test-kwargs-baseline)
161 |           (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (kwargs-fn 1 :not-num)))
162 |           (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (kwargs-fn 1 2 :a 1 {:b :not-num})))
163 | 
164 |           (testing "that the ex-info data looks correct"
165 |             (try (fail-kwargs 1 :not-num)
166 |                  (catch Exception ei
167 |                    (is (= 'clojure.test-clojure.instr/fail-kwargs (-> ei ex-data :clojure.alpha.spec.test/caller :var-scope)))))
168 | 
169 |             (try (fail-kwargs 1 2 :a 1 {:b :not-num})
170 |                  (catch Exception ei
171 |                    (is (= 'clojure.test-clojure.instr/fail-kwargs (-> ei ex-data :clojure.alpha.spec.test/caller :var-scope)))))))
172 | 
173 |         (testing "that the uninstrumented kwargs function operates as the raw function"
174 |           (stest/unstrument `kwargs-fn)
175 |           (test-kwargs-baseline)
176 |           (test-kwargs-extended))))
177 | 
178 |     (testing "that a var with no arglists meta is spec'd and checked at runtime"
179 |       (stest/instrument `add10 {})
180 |       (is (= 11 (add10 1)))
181 |       (is (thrown-with-msg? clojure.lang.ExceptionInfo #"did not conform to spec" (add10 :not-num)))
182 |       (is (= 11 (add10 1))))
183 | 
184 |     (testing "that a function with positional destructuring in its parameter list is spec'd and checked at runtime"
185 |       (stest/instrument `no-kwargs-destruct-fn {})
186 | 
187 |       (is (= [{:a 1} {}]         (no-kwargs-destruct-fn {:a 1} {})))
188 |       (is (= [{:a 1} 2 [3 4 5]]  (no-kwargs-destruct-fn {:a 1} 2 3 4 5))))))


--------------------------------------------------------------------------------
/src/main/clojure/clojure/alpha/spec/gen.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.alpha.spec.gen
 10 |     (:refer-clojure :exclude [boolean bytes cat hash-map list map not-empty set vector
 11 |                               char double int keyword symbol string uuid delay shuffle]))
 12 | 
 13 | (alias 'c 'clojure.core)
 14 | 
 15 | (defonce ^:private dynalock (Object.))
 16 | 
 17 | (defn- dynaload
 18 |   [s]
 19 |   (let [ns (namespace s)]
 20 |     (assert ns)
 21 |     (locking dynalock
 22 |       (require (c/symbol ns)))
 23 |     (let [v (resolve s)]
 24 |       (if v
 25 |         @v
 26 |         (throw (RuntimeException. (str "Var " s " is not on the classpath")))))))
 27 | 
 28 | (def ^:private quick-check-ref
 29 |      (c/delay (dynaload 'clojure.test.check/quick-check)))
 30 | (defn quick-check
 31 |   [& args]
 32 |   (apply @quick-check-ref args))
 33 | 
 34 | (def ^:private for-all*-ref
 35 |      (c/delay (dynaload 'clojure.test.check.properties/for-all*)))
 36 | (defn for-all*
 37 |   "Dynamically loaded clojure.test.check.properties/for-all*."
 38 |   [& args]
 39 |   (apply @for-all*-ref args))
 40 | 
 41 | (let [g? (c/delay (dynaload 'clojure.test.check.generators/generator?))
 42 |       g (c/delay (dynaload 'clojure.test.check.generators/generate))
 43 |       mkg (c/delay (dynaload 'clojure.test.check.generators/->Generator))]
 44 |   (defn generator?
 45 |     [x]
 46 |     (@g? x))
 47 |   (defn- generator
 48 |     [gfn]
 49 |     (@mkg gfn))
 50 |   (defn generate
 51 |     "Generate a single value using generator."
 52 |     [generator]
 53 |     (@g generator)))
 54 | 
 55 | (defn ^:skip-wiki delay-impl
 56 |   [gfnd]
 57 |   ;;N.B. depends on test.check impl details
 58 |   (generator (fn [rnd size]
 59 |                ((:gen @gfnd) rnd size))))
 60 | 
 61 | (defmacro delay
 62 |   "given body that returns a generator, returns a
 63 |   generator that delegates to that, but delays
 64 |   creation until used."
 65 |   [& body]
 66 |   `(delay-impl (c/delay ~@body)))
 67 | 
 68 | (defn gen-for-name
 69 |   "Dynamically loads test.check generator named s."
 70 |   [s]
 71 |   (let [g (dynaload s)]
 72 |     (if (generator? g)
 73 |       g
 74 |       (throw (RuntimeException. (str "Var " s " is not a generator"))))))
 75 | 
 76 | (defmacro ^:skip-wiki lazy-combinator
 77 |   "Implementation macro, do not call directly."
 78 |   [s]
 79 |   (let [fqn (c/symbol "clojure.test.check.generators" (name s))
 80 |         doc (str "Lazy loaded version of " fqn)]
 81 |     `(let [g# (c/delay (dynaload '~fqn))]
 82 |        (defn ~s
 83 |          ~doc
 84 |          [& ~'args]
 85 |          (apply @g# ~'args)))))
 86 | 
 87 | (defmacro ^:skip-wiki lazy-combinators
 88 |   "Implementation macro, do not call directly."
 89 |   [& syms]
 90 |   `(do
 91 |      ~@(c/map
 92 |         (fn [s] (c/list 'lazy-combinator s))
 93 |         syms)))
 94 | 
 95 | (lazy-combinators hash-map list map not-empty set vector vector-distinct vector-distinct-by elements
 96 |                   bind choose fmap one-of such-that tuple sample return
 97 |                   large-integer* double* frequency shuffle scale)
 98 | 
 99 | (defmacro ^:skip-wiki lazy-prim
100 |   "Implementation macro, do not call directly."
101 |   [s]
102 |   (let [fqn (c/symbol "clojure.test.check.generators" (name s))
103 |         doc (str "Fn returning " fqn)]
104 |     `(let [g# (c/delay (dynaload '~fqn))]
105 |        (defn ~s
106 |          ~doc
107 |          [& ~'args]
108 |          @g#))))
109 | 
110 | (defmacro ^:skip-wiki lazy-prims
111 |   "Implementation macro, do not call directly."
112 |   [& syms]
113 |   `(do
114 |      ~@(c/map
115 |         (fn [s] (c/list 'lazy-prim s))
116 |         syms)))
117 | 
118 | (lazy-prims any any-printable boolean bytes char char-alpha char-alphanumeric char-ascii double
119 |             int keyword keyword-ns large-integer ratio simple-type simple-type-printable
120 |             string string-ascii string-alphanumeric symbol symbol-ns uuid)
121 | 
122 | (defn cat
123 |   "Returns a generator of a sequence catenated from results of
124 | gens, each of which should generate something sequential."
125 |   [& gens]
126 |   (fmap (fn [[constructor & vs]]
127 |           (constructor (apply concat vs)))
128 |     (apply tuple (cons (elements [list* vec]) gens))))
129 | 
130 | (defn- qualified? [ident] (not (nil? (namespace ident))))
131 | 
132 | (def ^:private
133 |   gen-builtins
134 |   (c/delay
135 |    (let [simple (simple-type-printable)]
136 |      {any? (one-of [(return nil) (any-printable)])
137 |       some? (such-that some? (any-printable))
138 |       number? (one-of [(large-integer) (double)])
139 |       integer? (large-integer)
140 |       int? (large-integer)
141 |       pos-int? (large-integer* {:min 1})
142 |       neg-int? (large-integer* {:max -1})
143 |       nat-int? (large-integer* {:min 0})
144 |       float? (double)
145 |       double? (double)
146 |       boolean? (boolean)
147 |       string? (string-alphanumeric)
148 |       ident? (one-of [(keyword-ns) (symbol-ns)])
149 |       simple-ident? (one-of [(keyword) (symbol)])
150 |       qualified-ident? (such-that qualified? (one-of [(keyword-ns) (symbol-ns)]))
151 |       keyword? (keyword-ns)
152 |       simple-keyword? (keyword)
153 |       qualified-keyword? (such-that qualified? (keyword-ns))
154 |       symbol? (symbol-ns)
155 |       simple-symbol? (symbol)
156 |       qualified-symbol? (such-that qualified? (symbol-ns))
157 |       uuid? (uuid)
158 |       uri? (fmap #(java.net.URI/create (str "http://" % ".com")) (uuid))
159 |       decimal? (fmap #(BigDecimal/valueOf %)
160 |                     (double* {:infinite? false :NaN? false}))
161 |       inst? (fmap #(java.util.Date. %)
162 |                   (large-integer))
163 |       seqable? (one-of [(return nil)
164 |                         (list simple)
165 |                         (vector simple)
166 |                         (map simple simple)
167 |                         (set simple)
168 |                         (string-alphanumeric)])
169 |       indexed? (vector simple)
170 |       map? (map simple simple)
171 |       vector? (vector simple)
172 |       list? (list simple)
173 |       seq? (list simple)
174 |       char? (char)
175 |       set? (set simple)
176 |       nil? (return nil)
177 |       false? (return false)
178 |       true? (return true)
179 |       zero? (return 0)
180 |       rational? (one-of [(large-integer) (ratio)])
181 |       coll? (one-of [(map simple simple)
182 |                      (list simple)
183 |                      (vector simple)
184 |                      (set simple)])
185 |       empty? (elements [nil '() [] {} #{}])
186 |       associative? (one-of [(map simple simple) (vector simple)])
187 |       sequential? (one-of [(list simple) (vector simple)])
188 |       ratio? (such-that ratio? (ratio))
189 |       bytes? (bytes)})))
190 | 
191 | (defn gen-for-pred
192 |   "Given a predicate, returns a built-in generator if one exists."
193 |   [pred]
194 |   (if (set? pred)
195 |     (elements pred)
196 |     (get @gen-builtins pred)))
197 | 
198 | (comment
199 |   (require :reload 'clojure.alpha.spec.gen)
200 |   (in-ns 'clojure.alpha.spec.gen)
201 | 
202 |   ;; combinators, see call to lazy-combinators above for complete list
203 |   (generate (one-of [(gen-for-pred integer?) (gen-for-pred string?)]))
204 |   (generate (such-that #(< 10000 %) (gen-for-pred integer?)))
205 |   (let [reqs {:a (gen-for-pred number?)
206 |               :b (gen-for-pred ratio?)}
207 |         opts {:c (gen-for-pred string?)}]
208 |     (generate (bind (choose 0 (count opts))
209 |                     #(let [args (concat (seq reqs) (c/shuffle (seq opts)))]
210 |                        (->> args
211 |                             (take (+ % (count reqs)))
212 |                             (mapcat identity)
213 |                             (apply hash-map))))))
214 |   (generate (cat (list (gen-for-pred string?))
215 |                  (list (gen-for-pred ratio?))))
216 |   
217 |   ;; load your own generator
218 |   (gen-for-name 'clojure.test.check.generators/int)
219 |   
220 |   ;; failure modes
221 |   (gen-for-name 'unqualified)
222 |   (gen-for-name 'clojure.core/+)
223 |   (gen-for-name 'clojure.core/name-does-not-exist)
224 |   (gen-for-name 'ns.does.not.exist/f)
225 |   
226 |   )
227 | 
228 | 
229 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
  1 | Eclipse Public License - v 1.0
  2 | 
  3 | THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE PUBLIC
  4 | LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION OF THE PROGRAM
  5 | CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
  6 | 
  7 | 1. DEFINITIONS
  8 | 
  9 | "Contribution" means:
 10 | 
 11 | a) in the case of the initial Contributor, the initial code and documentation
 12 |    distributed under this Agreement, and
 13 | b) in the case of each subsequent Contributor:
 14 |     i) changes to the Program, and
 15 |    ii) additions to the Program;
 16 | 
 17 |    where such changes and/or additions to the Program originate from and are
 18 |    distributed by that particular Contributor. A Contribution 'originates'
 19 |    from a Contributor if it was added to the Program by such Contributor
 20 |    itself or anyone acting on such Contributor's behalf. Contributions do not
 21 |    include additions to the Program which: (i) are separate modules of
 22 |    software distributed in conjunction with the Program under their own
 23 |    license agreement, and (ii) are not derivative works of the Program.
 24 | 
 25 | "Contributor" means any person or entity that distributes the Program.
 26 | 
 27 | "Licensed Patents" mean patent claims licensable by a Contributor which are
 28 | necessarily infringed by the use or sale of its Contribution alone or when
 29 | combined with the Program.
 30 | 
 31 | "Program" means the Contributions distributed in accordance with this
 32 | Agreement.
 33 | 
 34 | "Recipient" means anyone who receives the Program under this Agreement,
 35 | including all Contributors.
 36 | 
 37 | 2. GRANT OF RIGHTS
 38 |   a) Subject to the terms of this Agreement, each Contributor hereby grants
 39 |      Recipient a non-exclusive, worldwide, royalty-free copyright license to
 40 |      reproduce, prepare derivative works of, publicly display, publicly
 41 |      perform, distribute and sublicense the Contribution of such Contributor,
 42 |      if any, and such derivative works, in source code and object code form.
 43 |   b) Subject to the terms of this Agreement, each Contributor hereby grants
 44 |      Recipient a non-exclusive, worldwide, royalty-free patent license under
 45 |      Licensed Patents to make, use, sell, offer to sell, import and otherwise
 46 |      transfer the Contribution of such Contributor, if any, in source code and
 47 |      object code form. This patent license shall apply to the combination of
 48 |      the Contribution and the Program if, at the time the Contribution is
 49 |      added by the Contributor, such addition of the Contribution causes such
 50 |      combination to be covered by the Licensed Patents. The patent license
 51 |      shall not apply to any other combinations which include the Contribution.
 52 |      No hardware per se is licensed hereunder.
 53 |   c) Recipient understands that although each Contributor grants the licenses
 54 |      to its Contributions set forth herein, no assurances are provided by any
 55 |      Contributor that the Program does not infringe the patent or other
 56 |      intellectual property rights of any other entity. Each Contributor
 57 |      disclaims any liability to Recipient for claims brought by any other
 58 |      entity based on infringement of intellectual property rights or
 59 |      otherwise. As a condition to exercising the rights and licenses granted
 60 |      hereunder, each Recipient hereby assumes sole responsibility to secure
 61 |      any other intellectual property rights needed, if any. For example, if a
 62 |      third party patent license is required to allow Recipient to distribute
 63 |      the Program, it is Recipient's responsibility to acquire that license
 64 |      before distributing the Program.
 65 |   d) Each Contributor represents that to its knowledge it has sufficient
 66 |      copyright rights in its Contribution, if any, to grant the copyright
 67 |      license set forth in this Agreement.
 68 | 
 69 | 3. REQUIREMENTS
 70 | 
 71 | A Contributor may choose to distribute the Program in object code form under
 72 | its own license agreement, provided that:
 73 | 
 74 |   a) it complies with the terms and conditions of this Agreement; and
 75 |   b) its license agreement:
 76 |       i) effectively disclaims on behalf of all Contributors all warranties
 77 |          and conditions, express and implied, including warranties or
 78 |          conditions of title and non-infringement, and implied warranties or
 79 |          conditions of merchantability and fitness for a particular purpose;
 80 |      ii) effectively excludes on behalf of all Contributors all liability for
 81 |          damages, including direct, indirect, special, incidental and
 82 |          consequential damages, such as lost profits;
 83 |     iii) states that any provisions which differ from this Agreement are
 84 |          offered by that Contributor alone and not by any other party; and
 85 |      iv) states that source code for the Program is available from such
 86 |          Contributor, and informs licensees how to obtain it in a reasonable
 87 |          manner on or through a medium customarily used for software exchange.
 88 | 
 89 | When the Program is made available in source code form:
 90 | 
 91 |   a) it must be made available under this Agreement; and
 92 |   b) a copy of this Agreement must be included with each copy of the Program.
 93 |      Contributors may not remove or alter any copyright notices contained
 94 |      within the Program.
 95 | 
 96 | Each Contributor must identify itself as the originator of its Contribution,
 97 | if
 98 | any, in a manner that reasonably allows subsequent Recipients to identify the
 99 | originator of the Contribution.
100 | 
101 | 4. COMMERCIAL DISTRIBUTION
102 | 
103 | Commercial distributors of software may accept certain responsibilities with
104 | respect to end users, business partners and the like. While this license is
105 | intended to facilitate the commercial use of the Program, the Contributor who
106 | includes the Program in a commercial product offering should do so in a manner
107 | which does not create potential liability for other Contributors. Therefore,
108 | if a Contributor includes the Program in a commercial product offering, such
109 | Contributor ("Commercial Contributor") hereby agrees to defend and indemnify
110 | every other Contributor ("Indemnified Contributor") against any losses,
111 | damages and costs (collectively "Losses") arising from claims, lawsuits and
112 | other legal actions brought by a third party against the Indemnified
113 | Contributor to the extent caused by the acts or omissions of such Commercial
114 | Contributor in connection with its distribution of the Program in a commercial
115 | product offering. The obligations in this section do not apply to any claims
116 | or Losses relating to any actual or alleged intellectual property
117 | infringement. In order to qualify, an Indemnified Contributor must:
118 | a) promptly notify the Commercial Contributor in writing of such claim, and
119 | b) allow the Commercial Contributor to control, and cooperate with the
120 | Commercial Contributor in, the defense and any related settlement
121 | negotiations. The Indemnified Contributor may participate in any such claim at
122 | its own expense.
123 | 
124 | For example, a Contributor might include the Program in a commercial product
125 | offering, Product X. That Contributor is then a Commercial Contributor. If
126 | that Commercial Contributor then makes performance claims, or offers
127 | warranties related to Product X, those performance claims and warranties are
128 | such Commercial Contributor's responsibility alone. Under this section, the
129 | Commercial Contributor would have to defend claims against the other
130 | Contributors related to those performance claims and warranties, and if a
131 | court requires any other Contributor to pay any damages as a result, the
132 | Commercial Contributor must pay those damages.
133 | 
134 | 5. NO WARRANTY
135 | 
136 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS PROVIDED ON AN
137 | "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
138 | IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF TITLE,
139 | NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Each
140 | Recipient is solely responsible for determining the appropriateness of using
141 | and distributing the Program and assumes all risks associated with its
142 | exercise of rights under this Agreement , including but not limited to the
143 | risks and costs of program errors, compliance with applicable laws, damage to
144 | or loss of data, programs or equipment, and unavailability or interruption of
145 | operations.
146 | 
147 | 6. DISCLAIMER OF LIABILITY
148 | 
149 | EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, NEITHER RECIPIENT NOR ANY
150 | CONTRIBUTORS SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL,
151 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION
152 | LOST PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
153 | CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
154 | ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
155 | EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE POSSIBILITY
156 | OF SUCH DAMAGES.
157 | 
158 | 7. GENERAL
159 | 
160 | If any provision of this Agreement is invalid or unenforceable under
161 | applicable law, it shall not affect the validity or enforceability of the
162 | remainder of the terms of this Agreement, and without further action by the
163 | parties hereto, such provision shall be reformed to the minimum extent
164 | necessary to make such provision valid and enforceable.
165 | 
166 | If Recipient institutes patent litigation against any entity (including a
167 | cross-claim or counterclaim in a lawsuit) alleging that the Program itself
168 | (excluding combinations of the Program with other software or hardware)
169 | infringes such Recipient's patent(s), then such Recipient's rights granted
170 | under Section 2(b) shall terminate as of the date such litigation is filed.
171 | 
172 | All Recipient's rights under this Agreement shall terminate if it fails to
173 | comply with any of the material terms or conditions of this Agreement and does
174 | not cure such failure in a reasonable period of time after becoming aware of
175 | such noncompliance. If all Recipient's rights under this Agreement terminate,
176 | Recipient agrees to cease use and distribution of the Program as soon as
177 | reasonably practicable. However, Recipient's obligations under this Agreement
178 | and any licenses granted by Recipient relating to the Program shall continue
179 | and survive.
180 | 
181 | Everyone is permitted to copy and distribute copies of this Agreement, but in
182 | order to avoid inconsistency the Agreement is copyrighted and may only be
183 | modified in the following manner. The Agreement Steward reserves the right to
184 | publish new versions (including revisions) of this Agreement from time to
185 | time. No one other than the Agreement Steward has the right to modify this
186 | Agreement. The Eclipse Foundation is the initial Agreement Steward. The
187 | Eclipse Foundation may assign the responsibility to serve as the Agreement
188 | Steward to a suitable separate entity. Each new version of the Agreement will
189 | be given a distinguishing version number. The Program (including
190 | Contributions) may always be distributed subject to the version of the
191 | Agreement under which it was received. In addition, after a new version of the
192 | Agreement is published, Contributor may elect to distribute the Program
193 | (including its Contributions) under the new version. Except as expressly
194 | stated in Sections 2(a) and 2(b) above, Recipient receives no rights or
195 | licenses to the intellectual property of any Contributor under this Agreement,
196 | whether expressly, by implication, estoppel or otherwise. All rights in the
197 | Program not expressly granted under this Agreement are reserved.
198 | 
199 | This Agreement is governed by the laws of the State of New York and the
200 | intellectual property laws of the United States of America. No party to this
201 | Agreement will bring a legal action under this Agreement more than one year
202 | after the cause of action arose. Each party waives its rights to a jury trial in
203 | any resulting litigation.
204 | 
205 | 
206 | 


--------------------------------------------------------------------------------
/epl-v10.html:
--------------------------------------------------------------------------------
  1 | <?xml version="1.0" encoding="ISO-8859-1" ?>
  2 | <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
  3 | <html xmlns="http://www.w3.org/1999/xhtml">
  4 | 
  5 | <head>
  6 | <meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1" />
  7 | <title>Eclipse Public License - Version 1.0</title>
  8 | <style type="text/css">
  9 |   body {
 10 |     size: 8.5in 11.0in;
 11 |     margin: 0.25in 0.5in 0.25in 0.5in;
 12 |     tab-interval: 0.5in;
 13 |     }
 14 |   p {  	
 15 |     margin-left: auto;
 16 |     margin-top:  0.5em;
 17 |     margin-bottom: 0.5em;
 18 |     }
 19 |   p.list {
 20 |   	margin-left: 0.5in;
 21 |     margin-top:  0.05em;
 22 |     margin-bottom: 0.05em;
 23 |     }
 24 |   </style>
 25 | 
 26 | </head>
 27 | 
 28 | <body lang="EN-US">
 29 | 
 30 | <p align=center><b>Eclipse Public License - v 1.0</b></p>
 31 | 
 32 | <p>THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
 33 | PUBLIC LICENSE (&quot;AGREEMENT&quot;). ANY USE, REPRODUCTION OR
 34 | DISTRIBUTION OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS
 35 | AGREEMENT.</p>
 36 | 
 37 | <p><b>1. DEFINITIONS</b></p>
 38 | 
 39 | <p>&quot;Contribution&quot; means:</p>
 40 | 
 41 | <p class="list">a) in the case of the initial Contributor, the initial
 42 | code and documentation distributed under this Agreement, and</p>
 43 | <p class="list">b) in the case of each subsequent Contributor:</p>
 44 | <p class="list">i) changes to the Program, and</p>
 45 | <p class="list">ii) additions to the Program;</p>
 46 | <p class="list">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.</p>
 54 | 
 55 | <p>&quot;Contributor&quot; means any person or entity that distributes
 56 | the Program.</p>
 57 | 
 58 | <p>&quot;Licensed Patents&quot; 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.</p>
 61 | 
 62 | <p>&quot;Program&quot; means the Contributions distributed in accordance
 63 | with this Agreement.</p>
 64 | 
 65 | <p>&quot;Recipient&quot; means anyone who receives the Program under
 66 | this Agreement, including all Contributors.</p>
 67 | 
 68 | <p><b>2. GRANT OF RIGHTS</b></p>
 69 | 
 70 | <p class="list">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.</p>
 76 | 
 77 | <p class="list">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.</p>
 88 | 
 89 | <p class="list">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.</p>
101 | 
102 | <p class="list">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.</p>
105 | 
106 | <p><b>3. REQUIREMENTS</b></p>
107 | 
108 | <p>A Contributor may choose to distribute the Program in object code
109 | form under its own license agreement, provided that:</p>
110 | 
111 | <p class="list">a) it complies with the terms and conditions of this
112 | Agreement; and</p>
113 | 
114 | <p class="list">b) its license agreement:</p>
115 | 
116 | <p class="list">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;</p>
120 | 
121 | <p class="list">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;</p>
124 | 
125 | <p class="list">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</p>
128 | 
129 | <p class="list">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.</p>
133 | 
134 | <p>When the Program is made available in source code form:</p>
135 | 
136 | <p class="list">a) it must be made available under this Agreement; and</p>
137 | 
138 | <p class="list">b) a copy of this Agreement must be included with each
139 | copy of the Program.</p>
140 | 
141 | <p>Contributors may not remove or alter any copyright notices contained
142 | within the Program.</p>
143 | 
144 | <p>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.</p>
147 | 
148 | <p><b>4. COMMERCIAL DISTRIBUTION</b></p>
149 | 
150 | <p>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 | (&quot;Commercial Contributor&quot;) hereby agrees to defend and
158 | indemnify every other Contributor (&quot;Indemnified Contributor&quot;)
159 | against any losses, damages and costs (collectively &quot;Losses&quot;)
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.</p>
172 | 
173 | <p>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.</p>
183 | 
184 | <p><b>5. NO WARRANTY</b></p>
185 | 
186 | <p>EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, THE PROGRAM IS
187 | PROVIDED ON AN &quot;AS IS&quot; 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.</p>
197 | 
198 | <p><b>6. DISCLAIMER OF LIABILITY</b></p>
199 | 
200 | <p>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.</p>
208 | 
209 | <p><b>7. GENERAL</b></p>
210 | 
211 | <p>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.</p>
216 | 
217 | <p>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.</p>
223 | 
224 | <p>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.</p>
232 | 
233 | <p>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.</p>
252 | 
253 | <p>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.</p>
258 | 
259 | </body>
260 | 
261 | </html>
262 | 


--------------------------------------------------------------------------------
/src/main/clojure/clojure/alpha/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.alpha.spec.test
 10 |   (:refer-clojure :exclude [test])
 11 |   (:require
 12 |    [clojure.pprint :as pp]
 13 |    [clojure.alpha.spec :as s]
 14 |    [clojure.alpha.spec.gen :as gen]
 15 |    [clojure.string :as str]))
 16 | 
 17 | (in-ns 'clojure.spec.test.check)
 18 | (in-ns 'clojure.alpha.spec.test)
 19 | (alias 'stc 'clojure.spec.test.check)
 20 | (alias 'sa 'clojure.spec.alpha)
 21 | 
 22 | (defn- throwable?
 23 |   [x]
 24 |   (instance? Throwable x))
 25 | 
 26 | (defn- ->var
 27 |   [s-or-v]
 28 |   (if (var? s-or-v)
 29 |     s-or-v
 30 |     (let [v (and (symbol? s-or-v) (resolve s-or-v))]
 31 |       (if (var? v)
 32 |         v
 33 |         (throw (IllegalArgumentException. (str (pr-str s-or-v) " does not name a var")))))))
 34 | 
 35 | (defn- collectionize
 36 |   [x]
 37 |   (if (symbol? x)
 38 |     (list x)
 39 |     x))
 40 | 
 41 | (defn enumerate-namespace
 42 |   "Given a symbol naming an ns, or a collection of such symbols,
 43 | returns the set of all symbols naming vars in those nses."
 44 |   [ns-sym-or-syms]
 45 |   (into
 46 |    #{}
 47 |    (mapcat (fn [ns-sym]
 48 |              (map
 49 |               (fn [name-sym]
 50 |                 (symbol (name ns-sym) (name name-sym)))
 51 |               (keys (ns-interns ns-sym)))))
 52 |    (collectionize ns-sym-or-syms)))
 53 | 
 54 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; instrument ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 55 | 
 56 | (def ^:private ^:dynamic *instrument-enabled*
 57 |   "if false, instrumented fns call straight through"
 58 |   true)
 59 | 
 60 | (defn- fn-spec?
 61 |   "Fn-spec must include at least :args or :ret specs."
 62 |   [m]
 63 |   (or (:args m) (:ret m)))
 64 | 
 65 | (defmacro with-instrument-disabled
 66 |   "Disables instrument's checking of calls, within a scope."
 67 |   [& body]
 68 |   `(binding [*instrument-enabled* nil]
 69 |      ~@body))
 70 | 
 71 | (def ^:private kvs-emu-name "--KVS--EMULATION--THUNK--")
 72 | 
 73 | (defn- thunk-frame? [s]
 74 |   (str/includes? s kvs-emu-name))
 75 | 
 76 | (defn- interpret-stack-trace-element
 77 |   "Given the vector-of-syms form of a stacktrace element produced
 78 | by e.g. Throwable->map, returns a map form that adds some keys
 79 | guessing the original Clojure names. Returns a map with
 80 | 
 81 |   :class         class name symbol from stack trace
 82 |   :method        method symbol from stack trace
 83 |   :file          filename from stack trace
 84 |   :line          line number from stack trace
 85 |   :var-scope     optional Clojure var symbol scoping fn def
 86 |   :local-fn      optional local Clojure symbol scoping fn def
 87 | 
 88 | For non-Clojure fns, :scope and :local-fn will be absent."
 89 |   [[cls method file line]]
 90 |   (let [clojure? (contains? '#{invoke invokeStatic} method)
 91 |         demunge #(clojure.lang.Compiler/demunge %)
 92 |         degensym #(str/replace % #"--.*" "")
 93 |         [ns-sym name-sym local] (when clojure?
 94 |                                   (->> (str/split (str cls) #"\$" 3)
 95 |                                        (map demunge)))]
 96 |     (merge {:file file
 97 |             :line line
 98 |             :method method
 99 |             :class cls}
100 |            (when (and ns-sym name-sym)
101 |              {:var-scope (symbol ns-sym name-sym)})
102 |            (when local
103 |              {:local-fn (symbol (degensym local))
104 |               :thunk? (thunk-frame? local)}))))
105 | 
106 | (defn- stacktrace-relevant-to-instrument
107 |   "Takes a coll of stack trace elements (as returned by
108 | StackTraceElement->vec) and returns a coll of maps as per
109 | interpret-stack-trace-element that are relevant to a
110 | failure in instrument."
111 |   [elems]
112 |   (let [plumbing? (fn [{:keys [var-scope thunk?]}]
113 |                     (or thunk?
114 |                         (contains? '#{clojure.alpha.spec.test/spec-checking-fn
115 |                                       clojure.core/apply}
116 |                                    var-scope)))]
117 |     (sequence (comp (map StackTraceElement->vec)
118 |                     (map interpret-stack-trace-element)
119 |                     (filter :var-scope)
120 |                     (drop-while plumbing?))
121 |               elems)))
122 | 
123 | (defn- spec-checking-fn
124 |   "Takes a function name, a function f, and an fspec and returns a thunk that
125 |   first conforms the arguments given then calls f with those arguments if
126 |   the conform succeeds. Otherwise, an exception is thrown containing information
127 |   about the conform failure."
128 |   [fn-name f fn-spec]
129 |   (let [fn-spec (@#'clojure.alpha.spec.impl/maybe-spec fn-spec)
130 |         conform! (fn [fn-name role spec data args]
131 |                    (let [conformed (s/conform spec data)]
132 |                      (if (= ::s/invalid conformed)
133 |                        (let [caller (->> (.getStackTrace (Thread/currentThread))
134 |                                          stacktrace-relevant-to-instrument
135 |                                          first)
136 |                              ed (merge (assoc (s/explain-data* spec [] [] [] data nil nil)
137 |                                          ::s/fn fn-name
138 |                                          ::s/args args
139 |                                          ::s/failure :instrument)
140 |                                        (when caller
141 |                                          {::caller (dissoc caller :class :method)}))]
142 |                          (throw (ex-info
143 |                                  (str "Call to " fn-name " did not conform to spec.")
144 |                                  ed)))
145 |                        conformed)))]
146 |     (fn
147 |      [& args]
148 |      (if *instrument-enabled*
149 |        (with-instrument-disabled
150 |          (when (:args fn-spec) (conform! fn-name :args (:args fn-spec) args args))
151 |          (binding [*instrument-enabled* true]
152 |            (.applyTo ^clojure.lang.IFn f args)))
153 |        (.applyTo ^clojure.lang.IFn f args)))))
154 | 
155 | (defn- no-fspec
156 |   [v spec]
157 |   (ex-info (str "Fn at " v " is not spec'ed.")
158 |            {:var v :spec spec ::sa/failure :no-fspec}))
159 | 
160 | (defonce ^:private instrumented-vars (atom {}))
161 | 
162 | (defn- find-varargs-decl
163 |   "Takes an arglist and returns the restargs binding form if found, else nil."
164 |   [arglist]
165 |   (let [[_ decl :as restargs] (->> arglist
166 |                                    (split-with (complement #{'&}))
167 |                                    second)]
168 |     (and (= 2 (count restargs))
169 |          decl)))
170 | 
171 | (defn- has-kwargs? [arglists]
172 |   (->> arglists (some find-varargs-decl) map?))
173 | 
174 | (defn- kwargs->kvs
175 |   "Takes the restargs of a kwargs function call and checks for a trailing element.
176 |   If found, that element is flattened into a sequence of key->value pairs and
177 |   concatenated onto the preceding arguments."
178 |   [args]
179 |   (if (even? (count args))
180 |      args
181 |      (concat (butlast args)
182 |              (reduce-kv (fn [acc k v] (->> acc (cons v) (cons k)))
183 |                         ()
184 |                         (last args)))))
185 | 
186 | (defn- gen-fixed-args-syms
187 |   "Takes an arglist and generates a vector of names corresponding to the fixed
188 |   args found."
189 |   [arglist]
190 |   (->> arglist (take-while (complement #{'&})) (map (fn [_] (gensym))) vec))
191 | 
192 | (defn- build-kwargs-body
193 |   "Takes a function name fn-name and arglist and returns code for a function body that
194 |   handles kwargs by calling fn-name with any fixed followed by its restargs transformed
195 |   from kwargs to kvs."
196 |   [fn-name arglist]
197 |   (let [alias (gensym "kwargs")
198 |         head-args (gen-fixed-args-syms arglist)]
199 |     (list (conj head-args '& alias)
200 |           `(apply ~fn-name ~@head-args (@#'kwargs->kvs ~alias)))))
201 | 
202 | (defn- build-varargs-body
203 |   "Takes a function name fn-name and arglist and returns code for a function body that
204 |   handles varargs by calling fn-name with any fixed args followed by its rest args."
205 |   [fn-name arglist]
206 |   (let [head-args (gen-fixed-args-syms arglist)
207 |         alias  (gensym "restargs")]
208 |     (list (conj head-args '& alias)
209 |           `(apply ~fn-name ~@head-args ~alias))))
210 | 
211 | (defn- build-fixed-args-body
212 |   "Takes a function name fn-name and arglist and returns code for a function body that
213 |   handles fixed args by calling fn-name with its fixed args."
214 |   [fn-name arglist]
215 |   (let [arglist (gen-fixed-args-syms arglist)]
216 |     (list arglist
217 |           `(~fn-name ~@arglist))))
218 | 
219 | (defn- build-flattener-code
220 |   "Takes argslists and generates code for a HOF that given a function, returns a forwarding thunk
221 |   of analogous arglists that ensures that kwargs are passed as kvs to the original function."
222 |   [arglists]
223 |   (let [closed-over-name (gensym "inner")]
224 |     `(fn [~closed-over-name]
225 |        (fn ~(symbol kvs-emu-name)
226 |          ~@(map (fn [arglist]
227 |                   (let [varargs-decl (find-varargs-decl arglist)]
228 |                     (cond (map? varargs-decl) (build-kwargs-body     closed-over-name arglist)
229 |                           varargs-decl        (build-varargs-body    closed-over-name arglist)
230 |                           :default            (build-fixed-args-body closed-over-name arglist))))
231 |                 (or arglists
232 |                     '([& args])))))))
233 | 
234 | (comment
235 |   ;; Given a function with the arglists (([a]) ([a b]) ([a b & kvs]))
236 |   ;; the flattener generated is below (with some gensym name cleanup for readability)
237 |   (fn [inner]
238 |     (fn
239 |       ([G__a] (inner G__a))
240 |       ([G__a G__b] (inner G__a G__b))
241 |       ([G__a G__b & G__kvs]
242 |        (apply inner G__a G__b (if (even? (count G__kvs))
243 |                                 G__kvs
244 |                                 (reduce-kv (fn [acc k v]
245 |                                              (->> acc (cons v) (cons k)))
246 |                                                   (butlast G__kvs)
247 |                                                   (last G__kvs)))))))
248 | )
249 | 
250 | (defn- maybe-wrap-kvs-emulation
251 |   "Takes an argslist and function f and returns f except when arglists
252 |   contains a kwargs binding, else wraps f with a forwarding thunk that
253 |   flattens a trailing map into kvs if present in the kwargs call."
254 |   [f arglists]
255 |   (if (has-kwargs? arglists)
256 |     (let [flattener-code (build-flattener-code arglists)
257 |           kvs-emu (eval flattener-code)]
258 |       (kvs-emu f))
259 |     f))
260 | 
261 | (defn- instrument-choose-fn
262 |   "Helper for instrument."
263 |   [f spec sym {over :gen :keys [stub replace]}]
264 |   (if (some #{sym} stub)
265 |     (-> spec (s/gen over) gen/generate)
266 |     (get replace sym f)))
267 | 
268 | (defn- instrument-choose-spec
269 |   "Helper for instrument"
270 |   [spec sym {overrides :spec}]
271 |   (get overrides sym spec))
272 | 
273 | (defn- instrument-1
274 |   [s opts]
275 |   (when-let [v (resolve s)]
276 |     (when-not (-> v meta :macro)
277 |       (let [spec (s/get-spec v)
278 |             {:keys [raw wrapped]} (get @instrumented-vars v)
279 |             current @v
280 |             to-wrap (if (= wrapped current) raw current)
281 |             ospec (or (instrument-choose-spec spec s opts)
282 |                       (throw (no-fspec v spec)))
283 |             ofn (instrument-choose-fn to-wrap ospec s opts)
284 |             checked (spec-checking-fn (symbol v) ofn ospec)
285 |             arglists (->> v meta :arglists (sort-by count) seq)
286 |             wrapped (maybe-wrap-kvs-emulation checked arglists)]
287 |         (alter-var-root v (constantly wrapped))
288 |         (swap! instrumented-vars assoc v {:raw to-wrap :wrapped wrapped})
289 |         (symbol v)))))
290 | 
291 | (defn- unstrument-1
292 |   [s]
293 |   (when-let [v (resolve s)]
294 |     (when-let [{:keys [raw wrapped]} (get @instrumented-vars v)]
295 |       (swap! instrumented-vars dissoc v)
296 |       (let [current @v]
297 |         (when (= wrapped current)
298 |           (alter-var-root v (constantly raw))
299 |           (symbol v))))))
300 | 
301 | (defn- opt-syms
302 |   "Returns set of symbols referenced by 'instrument' opts map"
303 |   [opts]
304 |   (reduce into #{} [(:stub opts) (keys (:replace opts)) (keys (:spec opts))]))
305 | 
306 | (defn- fn-spec-name?
307 |   [s]
308 |   (and (symbol? s)
309 |        (not (some-> (resolve s) meta :macro))))
310 | 
311 | (defn instrumentable-syms
312 |   "Given an opts map as per instrument, returns the set of syms
313 | that can be instrumented."
314 |   ([] (instrumentable-syms nil))
315 |   ([opts]
316 |      (assert (every? ident? (keys (:gen opts))) "instrument :gen expects ident keys")
317 |      (reduce into #{} [(filter fn-spec-name? (keys (s/registry)))
318 |                        (keys (:spec opts))
319 |                        (:stub opts)
320 |                        (keys (:replace opts))])))
321 | 
322 | (defn instrument
323 |   "Instruments the vars named by sym-or-syms, a symbol or collection
324 | of symbols, or all instrumentable vars if sym-or-syms is not
325 | specified.
326 | 
327 | If a var has an :args fn-spec, sets the var's root binding to a
328 | fn that checks arg conformance (throwing an exception on failure)
329 | before delegating to the original fn.
330 | 
331 | The opts map can be used to override registered specs, and/or to
332 | replace fn implementations entirely. Opts for symbols not included
333 | in sym-or-syms are ignored. This facilitates sharing a common
334 | options map across many different calls to instrument.
335 | 
336 | The opts map may have the following keys:
337 | 
338 |   :spec     a map from var-name symbols to override specs
339 |   :stub     a set of var-name symbols to be replaced by stubs
340 |   :gen      a map from spec names to generator overrides
341 |   :replace  a map from var-name symbols to replacement fns
342 | 
343 | :spec overrides registered fn-specs with specs your provide. Use
344 | :spec overrides to provide specs for libraries that do not have
345 | them, or to constrain your own use of a fn to a subset of its
346 | spec'ed contract.
347 | 
348 | :stub replaces a fn with a stub that checks :args, then uses the
349 | :ret spec to generate a return value.
350 | 
351 | :gen overrides are used only for :stub generation.
352 | 
353 | :replace replaces a fn with a fn that checks args conformance, then
354 | invokes the fn you provide, enabling arbitrary stubbing and mocking.
355 | 
356 | :spec can be used in combination with :stub or :replace.
357 | 
358 | Returns a collection of syms naming the vars instrumented."
359 |   ([] (instrument (instrumentable-syms)))
360 |   ([sym-or-syms] (instrument sym-or-syms nil))
361 |   ([sym-or-syms opts]
362 |      (locking instrumented-vars
363 |        (into
364 |         []
365 |         (comp (filter (instrumentable-syms opts))
366 |               (distinct)
367 |               (map #(instrument-1 % opts))
368 |               (remove nil?))
369 |         (collectionize sym-or-syms)))))
370 | 
371 | (defn unstrument
372 |   "Undoes instrument on the vars named by sym-or-syms, specified
373 | as in instrument. With no args, unstruments all instrumented vars.
374 | Returns a collection of syms naming the vars unstrumented."
375 |   ([] (unstrument (map symbol (keys @instrumented-vars))))
376 |   ([sym-or-syms]
377 |      (locking instrumented-vars
378 |        (into
379 |         []
380 |         (comp (filter symbol?)
381 |               (map unstrument-1)
382 |               (remove nil?))
383 |         (collectionize sym-or-syms)))))
384 | 
385 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; testing  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
386 | 
387 | (defn- explain-check
388 |   [args spec v role]
389 |   (ex-info
390 |    "Specification-based check failed"
391 |    (when-not (s/valid? spec v)
392 |      (let [ed (s/explain-data* spec [role] [] [] v nil nil)]
393 |        (if (nil? ed)
394 |          {::args args
395 |           ::val v
396 |           ::spec (s/form spec)
397 |           ::sa/failure :spec-explain-mismatch}
398 |          (assoc ed
399 |            ::args args
400 |            ::val v
401 |            ::sa/failure :check-failed))))))
402 | 
403 | (defn- check-call
404 |   "Returns true if call passes specs, otherwise *returns* an exception
405 | with explain-data + ::s/failure."
406 |   [f specs args]
407 |   (let [cargs (when (:args specs) (s/conform (:args specs) args))]
408 |     (if (= cargs ::s/invalid)
409 |       (explain-check args (:args specs) args :args)
410 |       (let [ret (apply f args)
411 |             cret (when (:ret specs) (s/conform (:ret specs) ret))]
412 |         (if (= cret ::s/invalid)
413 |           (explain-check args (:ret specs) ret :ret)
414 |           (if (and (:args specs) (:ret specs) (:fn specs))
415 |             (if (s/valid? (:fn specs) {:args cargs :ret cret})
416 |               true
417 |               (explain-check args (:fn specs) {:args cargs :ret cret} :fn))
418 |             true))))))
419 | 
420 | (defn- quick-check
421 |   [f specs {gen :gen opts ::stc/opts}]
422 |   (let [{:keys [num-tests] :or {num-tests 1000}} opts
423 |         g (try (s/gen (:args specs) gen) (catch Throwable t t))]
424 |     (if (throwable? g)
425 |       {:result g}
426 |       (let [prop (gen/for-all* [g] #(check-call f specs %))]
427 |         (apply gen/quick-check num-tests prop (mapcat identity opts))))))
428 | 
429 | (defn- make-check-result
430 |   "Builds spec result map."
431 |   [check-sym spec test-check-ret]
432 |   (merge {:spec spec
433 |           ::stc/ret test-check-ret}
434 |          (when check-sym
435 |            {:sym check-sym})
436 |          (when-let [result (-> test-check-ret :result)]
437 |            (when-not (true? result) {:failure result}))
438 |          (when-let [shrunk (-> test-check-ret :shrunk)]
439 |            {:failure (:result shrunk)})))
440 | 
441 | (defn- check-1
442 |   [{:keys [s f v spec]} opts]
443 |   (let [re-inst? (and v (seq (unstrument s)) true)
444 |         f (or f (when v @v))
445 |         specd (#'s/specize spec)]
446 |     (try
447 |      (cond
448 |       (or (nil? f) (some-> v meta :macro))
449 |       {:failure (ex-info "No fn to spec" {::sa/failure :no-fn})
450 |        :sym s :spec spec}
451 |     
452 |       (:args specd)
453 |       (let [tcret (quick-check f specd opts)]
454 |         (make-check-result s spec tcret))
455 |     
456 |       :default
457 |       {:failure (ex-info "No :args spec" {::sa/failure :no-args-spec})
458 |        :sym s :spec spec})
459 |      (finally
460 |       (when re-inst? (instrument s))))))
461 | 
462 | (defn- sym->check-map
463 |   [s]
464 |   (let [v (resolve s)]
465 |     {:s s
466 |      :v v
467 |      :spec (when v (s/get-spec v))}))
468 | 
469 | (defn- validate-check-opts
470 |   [opts]
471 |   (assert (every? ident? (keys (:gen opts))) "check :gen expects ident keys"))
472 | 
473 | (defn check-fn
474 |   "Runs generative tests for fn f using spec and opts. See
475 | 'check' for options and return."
476 |   ([f spec] (check-fn f spec nil))
477 |   ([f spec opts]
478 |      (validate-check-opts opts)
479 |      (check-1 {:f f :spec spec} opts)))
480 | 
481 | (defn checkable-syms
482 |   "Given an opts map as per check, returns the set of syms that
483 | can be checked."
484 |   ([] (checkable-syms nil))
485 |   ([opts]
486 |      (validate-check-opts opts)
487 |      (reduce into #{} [(filter fn-spec-name? (keys (s/registry)))
488 |                        (keys (:spec opts))])))
489 | 
490 | (defn check
491 |   "Run generative tests for spec conformance on vars named by
492 | sym-or-syms, a symbol or collection of symbols. If sym-or-syms
493 | is not specified, check all checkable vars.
494 | 
495 | The opts map includes the following optional keys, where stc
496 | aliases clojure.spec.test.check: 
497 | 
498 | ::stc/opts  opts to flow through test.check/quick-check
499 | :gen        map from spec names to generator overrides
500 | 
501 | The ::stc/opts include :num-tests in addition to the keys
502 | documented by test.check. Generator overrides are passed to
503 | spec/gen when generating function args.
504 | 
505 | Returns a lazy sequence of check result maps with the following
506 | keys
507 | 
508 | :spec       the spec tested
509 | :sym        optional symbol naming the var tested
510 | :failure    optional test failure
511 | ::stc/ret   optional value returned by test.check/quick-check
512 | 
513 | The value for :failure can be any exception. Exceptions thrown by
514 | spec itself will have an ::s/failure value in ex-data:
515 | 
516 | :check-failed   at least one checked return did not conform
517 | :no-args-spec   no :args spec provided
518 | :no-fn          no fn provided
519 | :no-fspec       no fspec provided
520 | :no-gen         unable to generate :args
521 | :instrument     invalid args detected by instrument
522 | "
523 |   ([] (check (checkable-syms)))
524 |   ([sym-or-syms] (check sym-or-syms nil))
525 |   ([sym-or-syms opts]
526 |      (->> (collectionize sym-or-syms)
527 |           (filter (checkable-syms opts))
528 |           (pmap
529 |            #(check-1 (sym->check-map %) opts)))))
530 | 
531 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; check reporting  ;;;;;;;;;;;;;;;;;;;;;;;;
532 | 
533 | (defn- failure-type
534 |   [x]
535 |   (::sa/failure (ex-data x)))
536 | 
537 | (defn- unwrap-failure
538 |   [x]
539 |   (if (failure-type x)
540 |     (ex-data x)
541 |     x))
542 | 
543 | (defn- result-type
544 |   "Returns the type of the check result. This can be any of the
545 | ::s/failure keywords documented in 'check', or:
546 | 
547 |   :check-passed   all checked fn returns conformed
548 |   :check-threw    checked fn threw an exception"
549 |   [ret]
550 |   (let [failure (:failure ret)]
551 |     (cond
552 |      (nil? failure) :check-passed
553 |      (failure-type failure) (failure-type failure)
554 |      :default :check-threw)))
555 | 
556 | (defn abbrev-result
557 |   "Given a check result, returns an abbreviated version
558 | suitable for summary use."
559 |   [x]
560 |   (if (:failure x)
561 |     (-> (dissoc x ::stc/ret)
562 |         (update :spec s/describe)
563 |         (update :failure unwrap-failure))
564 |     (dissoc x :spec ::stc/ret)))
565 | 
566 | (defn summarize-results
567 |   "Given a collection of check-results, e.g. from 'check', pretty
568 | prints the summary-result (default abbrev-result) of each.
569 | 
570 | Returns a map with :total, the total number of results, plus a
571 | key with a count for each different :type of result."
572 |   ([check-results] (summarize-results check-results abbrev-result))
573 |   ([check-results summary-result]
574 |      (reduce
575 |       (fn [summary result]
576 |         (pp/pprint (summary-result result))
577 |         (-> summary
578 |             (update :total inc)
579 |             (update (result-type result) (fnil inc 0))))
580 |       {:total 0}
581 |        check-results)))
582 | 
583 | 
584 | 
585 | 


--------------------------------------------------------------------------------
/src/test/clojure/clojure/test_clojure/spec.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
 10 |   (:require [clojure.alpha.spec :as s]
 11 |             [clojure.alpha.spec.protocols :as prot]
 12 |             [clojure.alpha.spec.gen :as gen]
 13 |             [clojure.alpha.spec.test :as stest]
 14 |             [clojure.test :refer :all]))
 15 | 
 16 | (alias 'sa 'clojure.spec.alpha)
 17 | (set! *warn-on-reflection* true)
 18 | 
 19 | (defmacro result-or-ex [x]
 20 |   `(try
 21 |      ~x
 22 |      (catch Throwable t#
 23 |        (.getName (class t#)))))
 24 | 
 25 | (def even-count? #(even? (count %)))
 26 | 
 27 | (defn submap?
 28 |   "Is m1 a subset of m2?"
 29 |   [m1 m2]
 30 |   (if (and (map? m1) (map? m2))
 31 |     (every? (fn [[k v]] (and (contains? m2 k)
 32 |                           (submap? v (get m2 k))))
 33 |       m1)
 34 |     (= m1 m2)))
 35 | 
 36 | (s/def ::k1 int?)
 37 | (s/def ::k2 keyword?)
 38 | (s/def ::mk1 int?)
 39 | (s/def ::mk2 keyword?)
 40 | (s/def ::mk3 string?)
 41 | (s/def ::m (s/keys :req [::mk1] :opt [::mk2 ::mk3]))
 42 | (s/def ::mu (s/keys :req-un [::mk1]))
 43 | (s/def ::sch (s/schema [::mk1 ::mk2 ::mk3]))
 44 | 
 45 | (deftest conform-explain
 46 |   (let [a (s/and #(> % 5) #(< % 10))
 47 |         a- (s/and- (s/cat :i int?) #(pos? (first %)))
 48 |         o (s/or :s string? :k keyword?)
 49 |         c (s/cat :a string? :b keyword?)
 50 |         either (s/alt :a string? :b keyword?)
 51 |         star (s/* keyword?)
 52 |         plus (s/+ keyword?)
 53 |         opt (s/? keyword?)
 54 |         andre (s/& (s/* keyword?) even-count?)
 55 |         andre2 (s/& (s/* keyword?) #{[:a]})
 56 |         me (s/keys)
 57 |         m (s/map-of keyword? string?)
 58 |         mkeys (s/map-of (s/and keyword? (s/conformer name)) any?)
 59 |         mkeys2 (s/map-of (s/and keyword? (s/conformer name)) any? :conform-keys true)
 60 |         s (s/coll-of (s/cat :tag keyword? :val any?) :kind list?)
 61 |         v (s/coll-of keyword? :kind vector?)
 62 |         coll (s/coll-of keyword?)
 63 |         lrange (s/int-in 7 42)
 64 |         drange (s/double-in :infinite? false :NaN? false :min 3.1 :max 3.2)
 65 |         irange (s/inst-in #inst "1939" #inst "1946")
 66 |         schema1 (s/schema [::k1 ::k2])
 67 |         schema2 (s/schema {:a int? :b keyword?})
 68 |         union (s/union [::k1 ::k2] {:a int? :b keyword?})
 69 |         select1 (s/select [] [::k1 ::k2])
 70 |         select2 (s/select [] [::k1 {::sch [::mk1]}])
 71 |         select* (s/select [::k1 ::k2] [*])
 72 |         ]
 73 |     (are [spec x conformed ed]
 74 |       (let [co (result-or-ex (s/conform spec x))
 75 |             e (result-or-ex (::sa/problems (s/explain-data spec x)))]
 76 |         (when (not= conformed co) (println "conform fail\n\texpect=" (pr-str conformed) "\n\tactual=" (pr-str co)))
 77 |         (when (not (every? true? (map submap? ed e)))
 78 |           (println "explain failures\n\texpect=" (pr-str ed) "\n\tactual failures=" (pr-str e) "\n\tsubmap?=" (map submap? ed e)))
 79 |         (and (= conformed co) (every? true? (map submap? ed e))))
 80 | 
 81 |       lrange 7 7 nil
 82 |       lrange 8 8 nil
 83 |       lrange 42 ::s/invalid [{:pred '(fn [%] (clojure.alpha.spec/int-in-range? 7 42 %)), :val 42}]
 84 | 
 85 |       irange #inst "1938" ::s/invalid [{:pred '(fn [%] (clojure.alpha.spec/inst-in-range? #inst "1939-01-01T00:00:00.000-00:00" #inst "1946-01-01T00:00:00.000-00:00" %)), :val #inst "1938"}]
 86 |       irange #inst "1942" #inst "1942" nil
 87 |       irange #inst "1946" ::s/invalid [{:pred '(fn [%] (clojure.alpha.spec/inst-in-range? #inst "1939-01-01T00:00:00.000-00:00" #inst "1946-01-01T00:00:00.000-00:00" %)), :val #inst "1946"}]
 88 | 
 89 |       drange 3.0 ::s/invalid [{:pred '(fn [%] (if 3.1 (clojure.core/<= 3.1 %) true)), :val 3.0}]
 90 |       drange 3.1 3.1 nil
 91 |       drange 3.2 3.2 nil
 92 |       drange Double/POSITIVE_INFINITY ::s/invalid [{:pred '(fn [%] (clojure.core/if-not false (clojure.core/not (Double/isInfinite %)))), :val Double/POSITIVE_INFINITY}]
 93 |       ;; can't use equality-based test for Double/NaN
 94 |       ;; drange Double/NaN ::s/invalid {[] {:pred '(fn [%] (clojure.core/not (Double/isNaN %))), :val Double/NaN}}
 95 | 
 96 |       (s/spec keyword?) :k :k nil
 97 |       (s/spec keyword?) nil ::s/invalid [{:pred `keyword? :val nil}]
 98 |       (s/spec keyword?) "abc" ::s/invalid [{:pred `keyword? :val "abc"}]
 99 | 
100 |       a 6 6 nil
101 |       a 3 ::s/invalid '[{:pred (fn [%] (clojure.core/> % 5)), :val 3}]
102 |       a 20 ::s/invalid '[{:pred (fn [%] (clojure.core/< % 10)), :val 20}]
103 |       a nil "java.lang.NullPointerException" "java.lang.NullPointerException"
104 |       a :k "java.lang.ClassCastException" "java.lang.ClassCastException"
105 | 
106 |       a- [1] {:i 1} nil
107 |       a- [] ::s/invalid '[{:val (), :pred clojure.core/int?, :reason "Insufficient input"}]
108 |       a- [-1] ::s/invalid '[{:val [-1], :pred (fn [%] (clojure.core/pos? (clojure.core/first %)))}]
109 |       a- :k ::s/invalid '[{:val :k, :pred (fn [%] (clojure.core/or (clojure.core/nil? %) (clojure.core/sequential? %)))}]
110 | 
111 |       o "a" [:s "a"] nil
112 |       o :a [:k :a] nil
113 |       o 'a ::s/invalid '[{:pred clojure.core/string?, :val a, :path [:s]} {:pred clojure.core/keyword?, :val a :path [:k]}]
114 | 
115 |       c nil ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/string?, :val (), :path [:a]}]
116 |       c [] ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/string?, :val (), :path [:a]}]
117 |       c [:a] ::s/invalid '[{:pred clojure.core/string?, :val :a, :path [:a], :in [0]}]
118 |       c ["a"] ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/keyword?, :val (), :path [:b]}]
119 |       c ["s" :k] '{:a "s" :b :k} nil
120 |       c ["s" :k 5] ::s/invalid '[{:reason "Extra input", :pred (clojure.alpha.spec/cat :a clojure.core/string? :b clojure.core/keyword?), :val (5)}]
121 |       (s/cat) nil {} nil
122 |       (s/cat) [5] ::s/invalid '[{:reason "Extra input", :pred (clojure.alpha.spec/cat), :val (5), :in [0]}]
123 | 
124 |       either nil ::s/invalid '[{:reason "Insufficient input", :pred (clojure.alpha.spec/alt :a clojure.core/string? :b clojure.core/keyword?), :val () :via []}]
125 |       either [] ::s/invalid '[{:reason "Insufficient input", :pred (clojure.alpha.spec/alt :a clojure.core/string? :b clojure.core/keyword?), :val () :via []}]
126 |       either [:k] [:b :k] nil
127 |       either ["s"] [:a "s"] nil
128 |       either [:b "s"] ::s/invalid '[{:reason "Extra input", :pred (clojure.alpha.spec/alt :a clojure.core/string? :b clojure.core/keyword?), :val ("s") :via []}]
129 | 
130 |       star nil [] nil
131 |       star [] [] nil
132 |       star [:k] [:k] nil
133 |       star [:k1 :k2] [:k1 :k2] nil
134 |       star [:k1 :k2 "x"] ::s/invalid '[{:pred clojure.core/keyword?, :val "x" :via []}]
135 |       star ["a"] ::s/invalid '[{:pred clojure.core/keyword?, :val "a" :via []}]
136 | 
137 |       plus nil ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/keyword?, :val () :via []}]
138 |       plus [] ::s/invalid '[{:reason "Insufficient input", :pred clojure.core/keyword?, :val () :via []}]
139 |       plus [:k] [:k] nil
140 |       plus [:k1 :k2] [:k1 :k2] nil
141 |       plus [:k1 :k2 "x"] ::s/invalid '[{:pred clojure.core/keyword?, :val "x", :in [2]}]
142 |       plus ["a"] ::s/invalid '[{:pred clojure.core/keyword?, :val "a" :via []}]
143 | 
144 |       opt nil nil nil
145 |       opt [] nil nil
146 |       opt :k ::s/invalid '[{:pred (fn [%] (clojure.core/or (clojure.core/nil? %) (clojure.core/sequential? %))), :val :k}]
147 |       opt [:k] :k nil
148 |       opt [:k1 :k2] ::s/invalid '[{:reason "Extra input", :pred (clojure.alpha.spec/? clojure.core/keyword?), :val (:k2)}]
149 |       opt [:k1 :k2 "x"] ::s/invalid '[{:reason "Extra input", :pred (clojure.alpha.spec/? clojure.core/keyword?), :val (:k2 "x")}]
150 |       opt ["a"] ::s/invalid '[{:pred clojure.core/keyword?, :val "a"}]
151 | 
152 |       andre nil nil nil
153 |       andre [] nil nil
154 |       andre :k ::s/invalid '[{:pred (fn [%] (clojure.core/or (clojure.core/nil? %) (clojure.core/sequential? %))), :val :k}]
155 |       andre [:k] ::s/invalid '[{:pred clojure.test-clojure.spec/even-count?, :val [:k]}]
156 |       andre [:j :k] [:j :k] nil
157 | 
158 |       andre2 nil ::s/invalid [{:pred #{[:a]}, :val []}]
159 |       andre2 [] ::s/invalid [{:pred #{[:a]}, :val []}]
160 |       andre2 [:a] [:a] nil
161 | 
162 |       ::m nil ::s/invalid '[{:pred clojure.core/map?, :val nil}]
163 |       ::m {} ::s/invalid '[{:pred (clojure.core/fn [%] (clojure.core/contains? % ::mk1)), :val {}}]
164 |       ::m {::mk1 :bad} ::s/invalid '[{:pred clojure.core/int?, :val :bad, :path [::mk1], :in [::mk1]}]
165 |       ::m {::mk1 100 ::mk2 :kw ::else true} {::mk1 100 ::mk2 :kw ::else true} nil
166 | 
167 |       ::mu nil ::s/invalid '[{:pred clojure.core/map?, :val nil}]
168 |       ::mu {} ::s/invalid '[{:pred (clojure.core/fn [%] (clojure.core/contains? % :mk1)), :val {}}]
169 |       ::mu {:mk1 :bad} ::s/invalid '[{:pred clojure.core/int?, :val :bad, :path [:mk1], :in [:mk1]}]
170 |       ::mu {:mk1 100} {:mk1 100} nil
171 | 
172 |       me nil ::s/invalid '[{:pred clojure.core/map?, :val nil}]
173 |       me {} {} nil
174 |       me {::a 1} {::a 1} nil
175 |       me {"a" 1} {"a" 1} nil
176 | 
177 |       m nil ::s/invalid '[{:pred clojure.core/map?, :val nil}]
178 |       m {} {} nil
179 |       m {:a "b"} {:a "b"} nil
180 | 
181 |       mkeys nil ::s/invalid '[{:pred clojure.core/map?, :val nil}]
182 |       mkeys {} {} nil
183 |       mkeys {:a 1 :b 2} {:a 1 :b 2} nil
184 | 
185 |       mkeys2 nil ::s/invalid '[{:pred clojure.core/map?, :val nil}]
186 |       mkeys2 {} {} nil
187 |       mkeys2 {:a 1 :b 2} {"a" 1 "b" 2} nil
188 | 
189 |       s '([:a 1] [:b "2"]) '({:tag :a :val 1} {:tag :b :val "2"}) nil
190 | 
191 |       v [:a :b] [:a :b] nil
192 |       v '(:a :b) ::s/invalid '[{:pred clojure.core/vector? :val (:a :b)}]
193 | 
194 |       coll nil ::s/invalid '[{:path [], :pred clojure.core/coll?, :val nil, :via [], :in []}]
195 |       coll [] [] nil
196 |       coll [:a] [:a] nil
197 |       coll [:a :b] [:a :b] nil
198 |       coll (map identity [:a :b]) '(:a :b) nil
199 |       ;;coll [:a "b"] ::s/invalid '[{:pred (coll-checker keyword?), :val [:a b]}]
200 | 
201 |       schema1 {} {} nil
202 |       schema1 {::k1 1 ::k2 :a} {::k1 1 ::k2 :a} nil
203 |       schema1 "oops" ::s/invalid [{:pred 'clojure.core/map? :val "oops"}]
204 |       schema1 {::k1 :a ::k2 1} ::s/invalid [{:pred 'clojure.core/int? :val :a} {:pred 'clojure.core/keyword? :val 1}]
205 | 
206 |       schema2 {} {} nil
207 |       schema2 {:a 10 :b :x} {:a 10 :b :x} nil
208 |       schema2 {:a :x :b 10} ::s/invalid [{:pred 'clojure.core/int? :val :x} {:pred 'clojure.core/keyword? :val 10}]
209 | 
210 |       union {} {} nil
211 |       union {::k1 1 ::k2 :a :a 1 :b :x} {::k1 1 ::k2 :a :a 1 :b :x} nil
212 |       union "oops" ::s/invalid [{:pred 'clojure.core/map? :val "oops"}]
213 |       union {::k1 :a ::k2 1} ::s/invalid [{:pred 'clojure.core/int? :val :a} {:pred 'clojure.core/keyword? :val 1}]
214 | 
215 |       select1 {::k1 1 ::k2 :a} {::k1 1 ::k2 :a} nil
216 |       select1 "oops" ::s/invalid [{:pred 'clojure.core/map? :val "oops"}]
217 |       select1 {::k1 1} ::s/invalid [{:pred '(clojure.core/fn [m] (clojure.core/contains? m ::k2)) :val {::k1 1}}]
218 |       select1 {::k1 1 ::k2 5} ::s/invalid [{:pred 'clojure.core/keyword? :val 5}]
219 | 
220 |       select2 {::k1 1} {::k1 1} nil
221 |       select2 {::k1 1 ::m {::mk1 10}} {::k1 1 ::m {::mk1 10}} nil
222 |       ;; problems here from both the registered key in the outer map and from missing selection
223 |       select2 {::k1 1 ::m {}} ::s/invalid [{:pred '(clojure.core/fn [%] (clojure.core/contains? % ::mk1)) :val {}}
224 |                                            {:pred '(clojure.core/fn [m] (clojure.core/contains? m ::mk1)) :val {}}]
225 | 
226 |       select* {::k1 1 ::k2 :a} {::k1 1 ::k2 :a} nil
227 |       select* "oops" ::s/invalid [{:pred 'clojure.core/map? :val "oops"}]
228 |       select* {::k1 1} ::s/invalid [{:pred '(clojure.core/fn [m] (clojure.core/contains? m ::k2)) :val {::k1 1}}]
229 |       select* {::k1 1 ::k2 5} ::s/invalid [{:pred 'clojure.core/keyword? :val 5}]
230 | 
231 |       )))
232 | 
233 | (deftest forms
234 |   ;; same
235 |   (are [s f] (= (s/form s) f)
236 |     ;; FIX - getting gensym args right now
237 |     ;;(s/and #(> % 5) #(< % 10))
238 |     ;;'(clojure.alpha.spec/and (fn [%] (> % 5)) (fn [%] (< % 10)))
239 | 
240 |     (s/or :s string? :k keyword?)
241 |     '(clojure.alpha.spec/or :s clojure.core/string? :k clojure.core/keyword?)
242 | 
243 |     (s/cat :a string? :b keyword?)
244 |     '(clojure.alpha.spec/cat :a clojure.core/string? :b clojure.core/keyword?)
245 | 
246 |     (s/alt :a string? :b keyword?)
247 |     '(clojure.alpha.spec/alt :a clojure.core/string? :b clojure.core/keyword?)
248 | 
249 |     (s/* keyword?)
250 |     '(clojure.alpha.spec/* clojure.core/keyword?)
251 | 
252 |     (s/+ keyword?)
253 |     '(clojure.alpha.spec/+ clojure.core/keyword?)
254 | 
255 |     (s/? keyword?)
256 |     '(clojure.alpha.spec/? clojure.core/keyword?)
257 | 
258 |     (s/& (s/* keyword?) pos?)
259 |     '(clojure.alpha.spec/& (clojure.alpha.spec/* clojure.core/keyword?) clojure.core/pos?)
260 | 
261 |     (s/& (s/* keyword?) #{[:a]})
262 |     '(clojure.alpha.spec/& (clojure.alpha.spec/* clojure.core/keyword?) #{[:a]})
263 | 
264 |     (s/map-of keyword? string?)
265 |     '(clojure.alpha.spec/map-of clojure.core/keyword? clojure.core/string?)
266 | 
267 |     (s/map-of (s/and keyword? (s/conformer name)) any? :conform-keys true)
268 |     '(clojure.alpha.spec/map-of (clojure.alpha.spec/and clojure.core/keyword? (clojure.alpha.spec/conformer clojure.core/name)) clojure.core/any? :conform-keys true)
269 | 
270 |     (s/coll-of (s/cat :tag keyword? :val any?) :kind list?)
271 |     '(clojure.alpha.spec/coll-of (clojure.alpha.spec/cat :tag clojure.core/keyword? :val clojure.core/any?) :kind clojure.core/list?)
272 | 
273 |     (s/coll-of keyword? :kind vector?)
274 |     '(clojure.alpha.spec/coll-of clojure.core/keyword? :kind clojure.core/vector?)
275 | 
276 |     (s/int-in 7 42)
277 |     '(clojure.alpha.spec/int-in 7 42)
278 | 
279 |     (s/double-in :infinite? false :NaN? false :min 3.1 :max 3.2)
280 |     '(clojure.alpha.spec/double-in :infinite? false :NaN? false :min 3.1 :max 3.2)
281 | 
282 |     (s/inst-in #inst "1939" #inst "1946")
283 |     '(clojure.alpha.spec/inst-in #inst "1939" #inst "1946")
284 | 
285 |     (s/schema [::k1 ::k2])
286 |     '(clojure.alpha.spec/schema [:clojure.test-clojure.spec/k1 :clojure.test-clojure.spec/k2])
287 | 
288 |     (s/schema {:a int? :b keyword?})
289 |     '(clojure.alpha.spec/schema [{:a clojure.core/int? :b clojure.core/keyword?}])
290 | 
291 |     (s/union [::k1 ::k2] {:a int? :b keyword?})
292 |     '(clojure.alpha.spec/union [:clojure.test-clojure.spec/k1 :clojure.test-clojure.spec/k2] {:a clojure.core/int? :b clojure.core/keyword?})
293 | 
294 |     (s/union [::k1 ::k2] (s/union {:a int?} {:b keyword?}))
295 |     '(clojure.alpha.spec/union [:clojure.test-clojure.spec/k1 :clojure.test-clojure.spec/k2] (clojure.alpha.spec/union {:a clojure.core/int?} {:b clojure.core/keyword?}))
296 | 
297 |     (s/select [] [::k1 ::k2])
298 |     '(clojure.alpha.spec/select [] [:clojure.test-clojure.spec/k1 :clojure.test-clojure.spec/k2])
299 | 
300 |     (s/select [] [::k1 {::sch [::mk1]}])
301 |     '(clojure.alpha.spec/select [] [:clojure.test-clojure.spec/k1 {:clojure.test-clojure.spec/sch [:clojure.test-clojure.spec/mk1]}])
302 | 
303 |     ;;(s/select [::k1 ::k2] [*])  ;; FIX - wildcard
304 |     ))
305 | 
306 | (deftest schemas
307 |   ;; nil schema
308 |   (is (= {} (prot/keyspecs* (s/schema nil))))
309 | 
310 |   ;; vector schema, qualified keys only
311 |   (is (= {::a ::a, ::b ::b} (prot/keyspecs* (s/schema [::a ::b]))))
312 | 
313 |   ;; map schema, unqualified keys only
314 |   (let [spk (prot/keyspecs* (s/schema {:a int?}))]
315 |     (is (= (keys spk) [:a]))
316 |     (is (= `int? (s/form (get spk :a)))))
317 | 
318 |   (is (= (s/form (s/schema* [{:a `string?}])) (s/form (s/schema* {:a `string?})))))
319 | 
320 | (deftest describing-evaled-specs
321 |   (let [sp (s/spec #{1 2})]
322 |     (is (= (s/describe sp) (s/form sp) #{1 2})))
323 | 
324 |   (is (= (s/describe (s/spec odd?)) 'odd?))
325 |   (is (= (s/form (s/spec odd?)) 'clojure.core/odd?))
326 | 
327 |   (is (= (s/describe (s/spec #(odd? %))) '(odd? %)))
328 |   (is (= (s/form (s/spec #(odd? %))) '(fn [%] (clojure.core/odd? %)))))
329 | 
330 | (defn check-conform-unform [spec vals expected-conforms]
331 |   (let [actual-conforms (map #(s/conform spec %) vals)
332 |         unforms (map #(s/unform spec %) actual-conforms)]
333 |     (is (= actual-conforms expected-conforms))
334 |     (is (= vals unforms))))
335 | 
336 | (deftest nilable-conform-unform
337 |   (check-conform-unform
338 |     (s/nilable int?)
339 |     [5 nil]
340 |     [5 nil])
341 |   (check-conform-unform
342 |     (s/nilable (s/or :i int? :s string?))
343 |     [5 "x" nil]
344 |     [[:i 5] [:s "x"] nil]))
345 | 
346 | (deftest nonconforming-conform-unform
347 |   (check-conform-unform
348 |     (s/nonconforming (s/or :i int? :s string?))
349 |     [5 "x"]
350 |     [5 "x"]))
351 | 
352 | (deftest coll-form
353 |   (are [spec form]
354 |     (= (s/form spec) form)
355 |     (s/map-of int? any?)
356 |     '(clojure.alpha.spec/map-of clojure.core/int? clojure.core/any?)
357 | 
358 |     (s/coll-of int?)
359 |     '(clojure.alpha.spec/coll-of clojure.core/int?)
360 | 
361 |     (s/every-kv int? int?)
362 |     '(clojure.alpha.spec/every-kv clojure.core/int? clojure.core/int?)
363 | 
364 |     (s/every int?)
365 |     '(clojure.alpha.spec/every clojure.core/int?)
366 | 
367 |     (s/coll-of (s/tuple (s/tuple int?)))
368 |     '(clojure.alpha.spec/coll-of (clojure.alpha.spec/tuple (clojure.alpha.spec/tuple clojure.core/int?)))
369 | 
370 |     (s/coll-of int? :kind vector?)
371 |     '(clojure.alpha.spec/coll-of clojure.core/int? :kind clojure.core/vector?)
372 | 
373 |     (s/coll-of int? :gen #(gen/return [1 2]))
374 |     '(clojure.alpha.spec/coll-of clojure.core/int? :gen (fn* [] (clojure.alpha.spec.gen/return [1 2])))))
375 | 
376 | (deftest coll-conform-unform
377 |   (check-conform-unform
378 |     (s/coll-of (s/or :i int? :s string?))
379 |     [[1 "x"]]
380 |     [[[:i 1] [:s "x"]]])
381 |   (check-conform-unform
382 |     (s/every (s/or :i int? :s string?))
383 |     [[1 "x"]]
384 |     [[1 "x"]])
385 |   (check-conform-unform
386 |     (s/map-of int? (s/or :i int? :s string?))
387 |     [{10 10 20 "x"}]
388 |     [{10 [:i 10] 20 [:s "x"]}])
389 |   (check-conform-unform
390 |     (s/map-of (s/or :i int? :s string?) int? :conform-keys true)
391 |     [{10 10 "x" 20}]
392 |     [{[:i 10] 10 [:s "x"] 20}])
393 |   (check-conform-unform
394 |     (s/every-kv int? (s/or :i int? :s string?))
395 |     [{10 10 20 "x"}]
396 |     [{10 10 20 "x"}]))
397 | 
398 | (deftest &-explain-pred
399 |   (are [val expected]
400 |     (= expected (-> (s/explain-data (s/& int? even?) val) ::sa/problems first :pred))
401 |     [] 'clojure.core/int?
402 |     [0 2] '(clojure.alpha.spec/& clojure.core/int? clojure.core/even?)))
403 | 
404 | (deftest keys-explain-pred
405 |   (is (= 'clojure.core/map? (-> (s/explain-data (s/keys :req [::x]) :a) ::sa/problems first :pred))))
406 | 
407 | (deftest remove-def
408 |   (is (= ::ABC (s/def ::ABC string?)))
409 |   (is (= ::ABC (s/def ::ABC nil)))
410 |   (is (nil? (s/get-spec ::ABC))))
411 | 
412 | ;; TODO replace this with a generative test once we have specs for s/keys
413 | (deftest map-spec-generators
414 |   (s/def ::a nat-int?)
415 |   (s/def ::b boolean?)
416 |   (s/def ::c keyword?)
417 |   (s/def ::d double?)
418 |   (s/def ::e inst?)
419 | 
420 |   (is (= #{[::a]
421 |            [::a ::b]
422 |            [::a ::b ::c]
423 |            [::a ::c]}
424 |          (->> (s/exercise (s/keys :req [::a] :opt [::b ::c]) 100)
425 |               (map (comp sort keys first))
426 |               (into #{}))))
427 | 
428 |   (is (= #{[:a]
429 |            [:a :b]
430 |            [:a :b :c]
431 |            [:a :c]}
432 |          (->> (s/exercise (s/keys :req-un [::a] :opt-un [::b ::c]) 100)
433 |               (map (comp sort keys first))
434 |               (into #{}))))
435 | 
436 |   (is (= #{[::a ::b]
437 |            [::a ::b ::c ::d]
438 |            [::a ::b ::c ::d ::e]
439 |            [::a ::b ::c ::e]
440 |            [::a ::c ::d]
441 |            [::a ::c ::d ::e]
442 |            [::a ::c ::e]}
443 |          (->> (s/exercise (s/keys :req [::a (or ::b (and ::c (or ::d ::e)))]) 200)
444 |               (map (comp vec sort keys first))
445 |               (into #{}))))
446 | 
447 |   (is (= #{[:a :b]
448 |            [:a :b :c :d]
449 |            [:a :b :c :d :e]
450 |            [:a :b :c :e]
451 |            [:a :c :d]
452 |            [:a :c :d :e]
453 |            [:a :c :e]}
454 |          (->> (s/exercise (s/keys :req-un [::a (or ::b (and ::c (or ::d ::e)))]) 200)
455 |               (map (comp vec sort keys first))
456 |               (into #{})))))
457 | 
458 | (deftest tuple-explain-pred
459 |   (are [val expected]
460 |     (= expected (-> (s/explain-data (s/tuple int?) val) ::sa/problems first :pred))
461 |     :a 'clojure.core/vector?
462 |     [] '(clojure.core/= (clojure.core/count %) 1)))
463 | 
464 | 
465 | ;; multi-spec
466 | 
467 | (s/def :event/type keyword?)
468 | (s/def :event/timestamp int?)
469 | (s/def :search/url string?)
470 | (s/def :error/message string?)
471 | (s/def :error/code int?)
472 | 
473 | (defmulti event-type :event/type)
474 | (defmethod event-type :event/search [_]
475 |   (s/keys :req [:event/type :event/timestamp :search/url]))
476 | (defmethod event-type :event/error [_]
477 |   (s/keys :req [:event/type :event/timestamp :error/message :error/code]))
478 | 
479 | (s/def :event/event (s/multi-spec event-type :event/type))
480 | 
481 | (deftest test-multi-spec
482 |   (is (true? (s/valid? :event/event
483 |                        {:event/type :event/search
484 |                         :event/timestamp 1463970123000
485 |                         :search/url "https://clojure.org"})))
486 |   (is (true? (s/valid? :event/event
487 |                        {:event/type :event/error
488 |                         :event/timestamp 1463970123000
489 |                         :error/message "Invalid host"
490 |                         :error/code 500})))
491 |   (is (= 1 (count (::sa/problems (s/explain-data
492 |                                    :event/event
493 |                                    {:event/type :event/restart})))))
494 |   (is (= 2 (count (::sa/problems (s/explain-data
495 |                                    :event/event
496 |                                    {:event/type :event/search :search/url 200}))))))
497 | 
498 | ;; forward declaration in regex should work
499 | ;(s/def :fwd/a (s/* (s/alt :k :fwd/k :i :fwd/i)))
500 | ;
501 | ;(s/def :fwd/k keyword?)
502 | ;(s/def :fwd/i int?)
503 | ;
504 | ;(deftest test-fwd
505 | ;  (is (true? (s/valid? :fwd/a [:a 10 100 :b])))
506 | ;  (is (= [[:k :a] [:i 10] [:i 100] [:k :b]]
507 | ;         (s/conform :fwd/a [:a 10 100 :b]))))
508 | 
509 | (deftest closed-spec-checking
510 |   ;; open schema means extra keys are ok
511 |   (is (true? (s/valid? ::sch {::mk1 100 ::k1 100})))
512 |   (is (= {::mk1 100 ::k1 100} (s/conform ::sch {::mk1 100 ::k1 100})))
513 | 
514 |   ;; but closed check won't allow it
515 |   (is (false? (s/valid? ::sch {::mk1 100 ::k1 100} {:closed #{::sch}})))
516 |   (is (s/invalid? (s/conform ::sch {::mk1 100 ::k1 100} {:closed #{::sch}})))
517 | 
518 |   ;; explain data on closed check
519 |   (is (submap?
520 |         {::sa/problems [{:path []
521 |                          :pred '(clojure.core/fn [%] (clojure.set/subset? (clojure.core/set (clojure.core/keys %)) #{::mk1 ::mk2 ::mk3}))
522 |                          :val {::mk1 100 ::k1 100}
523 |                          :via [::sch]
524 |                          :in []}]
525 |          ::sa/spec ::sch
526 |          ::sa/value {::mk1 100, ::k1 100}}
527 |         (s/explain-data ::sch {::mk1 100 ::k1 100} {:closed #{::sch}}))))
528 | 
529 | (comment
530 |   (require '[clojure.test :refer (run-tests)])
531 |   (in-ns 'clojure.test-clojure.spec)
532 |   (run-tests)
533 | 
534 |   )
535 | 


--------------------------------------------------------------------------------
/src/main/clojure/clojure/alpha/spec.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.alpha.spec
  17 |   (:refer-clojure :exclude [+ * and assert or cat def keys merge comp])
  18 |   (:require [clojure.alpha.spec.protocols :as protocols
  19 |              :refer [conform* unform* explain* gen* with-gen* describe*]]
  20 |             [clojure.walk :as walk]
  21 |             [clojure.alpha.spec.gen :as gen])
  22 |   (:import [clojure.alpha.spec.protocols Spec Schema]))
  23 | 
  24 | (alias 'c 'clojure.core)
  25 | (alias 'sa 'clojure.spec.alpha)
  26 | 
  27 | (def ^:dynamic *recursion-limit*
  28 |   "A soft limit on how many times a branching spec (or/alt/*/opt-keys/multi-spec)
  29 |   can be recursed through during generation. After this a
  30 |   non-recursive branch will be chosen."
  31 |   4)
  32 | 
  33 | (def ^:dynamic *fspec-iterations*
  34 |   "The number of times an anonymous fn specified by fspec will be (generatively) tested during conform"
  35 |   21)
  36 | 
  37 | (def ^:dynamic *coll-check-limit*
  38 |   "The number of elements validated in a collection spec'ed with 'every'"
  39 |   101)
  40 | 
  41 | (def ^:dynamic *coll-error-limit*
  42 |   "The number of errors reported by explain in a collection spec'ed with 'every'"
  43 |   20)
  44 | 
  45 | (defonce ^:private registry-ref (atom {}))
  46 | 
  47 | (defn registry
  48 |   "Returns the registry map, prefer 'get-spec' to lookup a spec by name"
  49 |   []
  50 |   @registry-ref)
  51 | 
  52 | (defn spec?
  53 |   "returns x if x is a spec object, else logical false"
  54 |   [x]
  55 |   (when (c/or (instance? Spec x) (-> x meta (contains? `conform*)))
  56 |     x))
  57 | 
  58 | (defn schema?
  59 |   "Returns x if x is a schema object, else logical false"
  60 |   [x]
  61 |   (instance? Schema x))
  62 | 
  63 | (defn get-spec
  64 |   "Returns spec registered for keyword/symbol/var k, or nil."
  65 |   [k]
  66 |   (get (registry) (if (keyword? k) k (symbol k))))
  67 | 
  68 | (defn- deep-resolve [reg k]
  69 |   (loop [spec k]
  70 |     (if (ident? spec)
  71 |       (recur (get reg spec))
  72 |       spec)))
  73 | 
  74 | (defn- reg-resolve
  75 |   "returns the spec/regex at end of alias chain starting with k, nil if not found, k if k not ident"
  76 |   [k]
  77 |   (if (ident? k)
  78 |     (let [reg @registry-ref
  79 |           spec (get reg k)]
  80 |       (if-not (ident? spec)
  81 |         spec
  82 |         (deep-resolve reg spec)))
  83 |     k))
  84 | 
  85 | (defn- reg-resolve!
  86 |   "returns the spec/regex at end of alias chain starting with k, throws if not found, k if k not ident"
  87 |   [k]
  88 |   (if (ident? k)
  89 |     (c/or (reg-resolve k)
  90 |           (throw (Exception. (str "Unable to resolve spec: " k))))
  91 |     k))
  92 | 
  93 | (defn regex?
  94 |   "returns x if x is a (clojure.spec) regex op, else logical false"
  95 |   [x]
  96 |   (c/and (::op x) x))
  97 | 
  98 | (defn- with-name [spec name]
  99 |   (cond
 100 |     (ident? spec) spec
 101 |     (regex? spec) (assoc spec ::name name)
 102 | 
 103 |     (instance? clojure.lang.IObj spec)
 104 |     (with-meta spec (assoc (meta spec) ::name name))))
 105 | 
 106 | (defn- spec-name [spec]
 107 |   (cond
 108 |     (ident? spec) spec
 109 | 
 110 |     (regex? spec) (::name spec)
 111 | 
 112 |     (instance? clojure.lang.IObj spec)
 113 |     (-> (meta spec) ::name)))
 114 | 
 115 | (defn invalid?
 116 |   "tests the validity of a conform return value"
 117 |   [ret]
 118 |   (identical? ::invalid ret))
 119 | 
 120 | (defn- unfn [expr]
 121 |   (if (c/and (seq? expr)
 122 |              (symbol? (first expr))
 123 |              (= "fn*" (name (first expr))))
 124 |     (let [[[s] & form] (rest expr)]
 125 |       (conj (walk/postwalk-replace {s '%} form) '[%] 'fn))
 126 |     expr))
 127 | 
 128 | (defn- res [form]
 129 |   (walk/postwalk
 130 |     #(cond
 131 |        (keyword? %) %
 132 |        (symbol? %) (c/or (some-> % resolve symbol) %)
 133 |        (sequential? %) (unfn %)
 134 |        :else %)
 135 |     form))
 136 | 
 137 | (defmulti expand-spec
 138 |   "Create a symbolic spec map from an explicated spec form. This is an
 139 |   extension point for adding new spec ops. Generally, consumers should
 140 |   instead call `resolve-spec`. For anything other than symbolic spec maps,
 141 |   return the same object unchanged."
 142 |   (fn [qform] (when (c/or (list? qform) (seq? qform)) (first qform))))
 143 | 
 144 | (defmethod expand-spec :default [o] o)
 145 | 
 146 | (defmulti create-spec
 147 |   "Create a spec object from an explicated spec map. This is an extension
 148 |   point for adding new spec ops. Generally, consumers should instead call
 149 |   `resolve-spec`."
 150 |   (fn [smap] (when (map? smap) (:clojure.spec/op smap))))
 151 | 
 152 | (defmethod create-spec :default [o] o)
 153 | 
 154 | (defn- pred-impl
 155 |   ([sym]
 156 |    (pred-impl sym nil))
 157 |   ([sym gfn]
 158 |    (let [pred (deref (find-var sym))]
 159 |      (reify
 160 |        protocols/Spec
 161 |        (conform* [_ x settings-key settings]
 162 |          (let [ret (pred x)] (if ret x ::invalid)))
 163 |        (unform* [_ x] x)
 164 |        (explain* [_ path via in x settings-key settings]
 165 |          (when (not (pred x))
 166 |            [{:path path :pred sym :val x :via via :in in}]))
 167 |        (gen* [_ _ _ _] (if gfn (gfn) (gen/gen-for-pred pred)))
 168 |        (with-gen* [_ gfn] (pred-impl sym gfn))
 169 |        (describe* [_] sym)))))
 170 | 
 171 | (defn- constant-val?
 172 |   [x]
 173 |   (c/or (nil? x)
 174 |         (boolean? x)
 175 |         (number? x)
 176 |         (string? x)
 177 |         (ident? x)
 178 |         (char? x)
 179 |         (c/and (coll? x) (empty? x))
 180 |         (c/and (c/or (vector? x) (set? x) (map? x))
 181 |                (every? constant-val? x))))
 182 | 
 183 | (defn- set-impl
 184 |   ([set-vals]
 185 |    (set-impl set-vals nil))
 186 |   ([set-vals gfn]
 187 |    (c/assert (every? constant-val? set-vals) "set specs must contain constant values")
 188 |    (let [pred #(contains? set-vals %)]
 189 |      (reify
 190 |        protocols/Spec
 191 |        (conform* [_ x settings-key settings]
 192 |          (let [ret (pred x)] (if ret x ::invalid)))
 193 |        (unform* [_ x] x)
 194 |        (explain* [_ path via in x settings-key settings]
 195 |          (when (not (pred x))
 196 |            [{:path path :pred set-vals :val x :via via :in in}]))
 197 |        (gen* [_ _ _ _] (if gfn (gfn) (gen/gen-for-pred set-vals)))
 198 |        (with-gen* [_ gfn] (set-impl set-vals gfn))
 199 |        (describe* [_] set-vals)))))
 200 | 
 201 | (declare gensub)
 202 | 
 203 | (defn resolve-fn
 204 |   "Resolves a symbolic function to a function object (predicate)."
 205 |   [fn-form]
 206 |   (eval fn-form))
 207 | 
 208 | (defn resolve-spec
 209 |   "Returns a spec object given a fully-qualified spec op form, symbol, set,
 210 |   or registry identifier. If needed, use 'explicate' to qualify forms."
 211 |   [qform]
 212 |   (cond
 213 |     (keyword? qform) (reg-resolve! qform)
 214 |     (qualified-symbol? qform) (pred-impl (res qform))
 215 |     (c/or (list? qform) (seq? qform)) (-> qform expand-spec create-spec)
 216 |     (map? qform) (create-spec qform)
 217 |     (set? qform) (set-impl qform)
 218 |     (nil? qform) nil
 219 |     (simple-symbol? qform) (throw (IllegalArgumentException. (str "Symbolic spec must be fully-qualified: " qform)))
 220 |     :else (throw (IllegalArgumentException. (str "Unknown spec op of type: " (class qform))))))
 221 | 
 222 | (defn- specize [x]
 223 |   (if (keyword? x) (reg-resolve! x) x))
 224 | 
 225 | (defn schema*
 226 |   "Returns a schema object given a fully-qualified schema definition.
 227 |   If needed use 'explicate' to qualify forms."
 228 |   [sform]
 229 |   (cond
 230 |     (keyword? sform) (reg-resolve! sform)
 231 |     (vector? sform) (create-spec `{:clojure.spec/op schema, :schema ~sform})
 232 |     (map? sform) (create-spec `{:clojure.spec/op schema, :schema [~sform]})
 233 |     (c/or (list? sform) (seq? sform)) (-> sform expand-spec create-spec)
 234 |     (nil? sform) nil
 235 |     :else (throw (IllegalArgumentException. (str "Unknown schema op of type: " (class sform))))))
 236 | 
 237 | (defn conform
 238 |   "Given a spec and a value, returns :clojure.alpha.spec/invalid
 239 | 	if value does not match spec, else the (possibly destructured) value."
 240 |   ([spec x]
 241 |     (conform spec x nil))
 242 |   ([spec x settings]
 243 |    (if (keyword? spec)
 244 |      (conform* (reg-resolve! spec) x spec settings)
 245 |      (conform* spec x nil settings))))
 246 | 
 247 | (defn unform
 248 |   "Given a spec and a value created by or compliant with a call to
 249 |   'conform' with the same spec, returns a value with all conform
 250 |   destructuring undone."
 251 |   [spec x]
 252 |   (unform* (specize spec) x))
 253 | 
 254 | (defn form
 255 |   "returns the spec as data"
 256 |   [spec]
 257 |   ;;TODO - incorporate gens
 258 |   (describe* (specize spec)))
 259 | 
 260 | (defn- abbrev [form]
 261 |   (cond
 262 |    (seq? form)
 263 |    (walk/postwalk (fn [form]
 264 |                     (cond
 265 |                      (c/and (symbol? form) (namespace form))
 266 |                      (-> form name symbol)
 267 | 
 268 |                      (c/and (seq? form) (= 'fn (first form)) (= '[%] (second form)))
 269 |                      (last form)
 270 |                      
 271 |                      :else form))
 272 |                   form)
 273 | 
 274 |    (c/and (symbol? form) (namespace form))
 275 |    (-> form name symbol)
 276 | 
 277 |    :else form))
 278 | 
 279 | (defn describe
 280 |   "returns an abbreviated description of the spec as data"
 281 |   [spec]
 282 |   (abbrev (form spec)))
 283 | 
 284 | (defn explain-data* [spec path via in x settings-key settings]
 285 |   (let [probs (explain* (specize spec) path via in x settings-key settings)]
 286 |     (when-not (empty? probs)
 287 |       {::sa/problems probs
 288 |        ::sa/spec spec
 289 |        ::sa/value x})))
 290 | 
 291 | (defn explain-data
 292 |   "Given a spec and a value x which ought to conform, returns nil if x
 293 |   conforms, else a map with at least the key ::problems whose value is
 294 |   a collection of problem-maps, where problem-map has at least :path :pred and :val
 295 |   keys describing the predicate and the value that failed at that
 296 |   path."
 297 |   ([spec x]
 298 |    (explain-data spec x nil))
 299 |   ([spec x settings]
 300 |    (let [settings-key (when (keyword? spec) spec)]
 301 |      (explain-data* spec [] (if-let [name (spec-name spec)] [name] []) [] x settings-key settings))))
 302 | 
 303 | (defn explain-printer
 304 |   "Default printer for explain-data. nil indicates a successful validation."
 305 |   [ed]
 306 |   (if ed
 307 |     (let [problems (->> (::sa/problems ed)
 308 |                      (sort-by #(- (count (:in %))))
 309 |                      (sort-by #(- (count (:path %)))))]
 310 |       ;;(prn {:ed ed})
 311 |       (doseq [{:keys [path pred val reason via in] :as prob} problems]
 312 |         (pr val)
 313 |         (print " - failed: ")
 314 |         (if reason (print reason) (pr (abbrev pred)))
 315 |         (when-not (empty? in)
 316 |           (print (str " in: " (pr-str in))))
 317 |         (when-not (empty? path)
 318 |           (print (str " at: " (pr-str path))))
 319 |         (when-not (empty? via)
 320 |           (print (str " spec: " (pr-str (last via)))))
 321 |         (doseq [[k v] prob]
 322 |           (when-not (#{:path :pred :val :reason :via :in} k)
 323 |             (print "\n\t" (pr-str k) " ")
 324 |             (pr v)))
 325 |         (newline)))
 326 |     (println "Success!")))
 327 | 
 328 | (def ^:dynamic *explain-out* explain-printer)
 329 | 
 330 | (defn explain-out
 331 |   "Prints explanation data (per 'explain-data') to *out* using the printer in *explain-out*,
 332 |    by default explain-printer."
 333 |   [ed]
 334 |   (*explain-out* ed))
 335 | 
 336 | (defn explain
 337 |   "Given a spec and a value that fails to conform, prints an explanation to *out*."
 338 |   ([spec x]
 339 |    (explain spec x nil))
 340 |   ([spec x settings]
 341 |    (explain-out (explain-data spec x settings))))
 342 | 
 343 | (defn explain-str
 344 |   "Given a spec and a value that fails to conform, returns an explanation as a string."
 345 |   (^String [spec x]
 346 |    (explain-str spec x nil))
 347 |   (^String [spec x settings]
 348 |    (with-out-str (explain spec x settings))))
 349 | 
 350 | (defn valid?
 351 |   "Helper function that returns true when x is valid for spec."
 352 |   ([spec x]
 353 |     (valid? spec x nil))
 354 |   ([spec x settings]
 355 |    (if (keyword? spec)
 356 |      (let [spec' (reg-resolve! spec)]
 357 |        (not (invalid? (conform* spec' x spec settings))))
 358 |      (not (invalid? (conform* spec x nil settings))))))
 359 | 
 360 | (defn- gensub
 361 |   [spec overrides path rmap form]
 362 |   ;;(prn {:spec spec :over overrides :path path :form form})
 363 |   (let [spec (specize spec)]
 364 |     (if-let [g (c/or (when-let [gfn (c/or (get overrides (c/or (spec-name spec) spec))
 365 |                                           (get overrides path))]
 366 |                        (gfn))
 367 |                      (gen* spec overrides path rmap))]
 368 |       (gen/such-that #(valid? spec %) g 100)
 369 |       (let [abbr (abbrev form)]
 370 |         (throw (ex-info (str "Unable to construct gen at: " path " for: " abbr)
 371 |                         {::sa/path path ::sa/form form ::sa/failure :no-gen}))))))
 372 | 
 373 | (defn gen
 374 |   "Given a spec, returns the generator for it, or throws if none can
 375 |   be constructed. Optionally an overrides map can be provided which
 376 |   should map spec names or paths (vectors of keywords) to no-arg
 377 |   generator-creating fns. These will be used instead of the generators at those
 378 |   names/paths. Note that parent generator (in the spec or overrides
 379 |   map) will supersede those of any subtrees. A generator for a regex
 380 |   op must always return a sequential collection (i.e. a generator for
 381 |   s/? should return either an empty sequence/vector or a
 382 |   sequence/vector with one item in it)"
 383 |   ([spec] (gen spec nil))
 384 |   ([spec overrides] (gensub spec overrides [] {::recursion-limit *recursion-limit*} spec)))
 385 | 
 386 | (defn- explicate-1 [a-ns form]
 387 |   (walk/postwalk
 388 |     #(cond
 389 |        (keyword? %) %
 390 |        (symbol? %) (if-let [rs (some->> % (ns-resolve a-ns))]
 391 |                      (if (var? rs) (symbol rs) %)
 392 |                      %)
 393 |        :else %)
 394 |     form))
 395 | 
 396 | (defn explicate
 397 |   "Return a fully-qualified form given a namespace name context and a form"
 398 |   [ns-name form]
 399 |   (let [a-ns (find-ns ns-name)]
 400 |     (if (sequential? form)
 401 |       (map (partial explicate-1 a-ns) form)
 402 |       (explicate-1 a-ns form))))
 403 | 
 404 | (defn- ns-qualify
 405 |   "Qualify symbol s by resolving it or using the current *ns*."
 406 |   [s]
 407 |   (if-let [ns-sym (some-> s namespace symbol)]
 408 |     (c/or (some-> (get (ns-aliases *ns*) ns-sym) str (symbol (name s)))
 409 |           s)
 410 |     (symbol (str (.name *ns*)) (str s))))
 411 | 
 412 | (defmacro schema
 413 |   "Given a literal vector or map schema, expand to a proper explicated spec
 414 |   form, which when evaluated yields a schema object."
 415 |   [& coll]
 416 |   `(resolve-spec '~(explicate (ns-name *ns*) `(schema ~@coll))))
 417 | 
 418 | (defmacro union
 419 |   "Takes schemas and unions them, returning a schema object"
 420 |   [& schemas]
 421 |   `(resolve-spec '~(explicate (ns-name *ns*) `(union ~@schemas))))
 422 | 
 423 | (defmacro spec
 424 |   "Given a function symbol, set of constants, or anonymous function,
 425 |   returns a spec object."
 426 |   [s]
 427 |   `(resolve-spec '~(explicate (ns-name *ns*) s)))
 428 | 
 429 | (defn register
 430 |   "Given a namespace-qualified keyword or resolvable symbol k, and a
 431 |   spec-name or spec object, makes an entry in the registry mapping k
 432 |   to the spec. Use nil to remove an entry in the registry for k."
 433 |   [k s]
 434 |   (c/assert (c/and (ident? k) (namespace k)) "k must be namespaced keyword or resolvable symbol")
 435 |   (if (nil? s)
 436 |     (swap! registry-ref dissoc k)
 437 |     (swap! registry-ref assoc k (with-name s k)))
 438 |   k)
 439 | 
 440 | (defmacro def
 441 |   "Given a namespace-qualified keyword or resolvable symbol k, and a
 442 |   spec-name or symbolic spec, makes an entry in the registry mapping k
 443 |   to the spec. Use nil to remove an entry in the registry for k."
 444 |   [k spec-form]
 445 |   (let [k (if (symbol? k) (ns-qualify k) k)
 446 |         spec-def (cond
 447 |                    (keyword? spec-form) spec-form
 448 |                    (symbol? spec-form) `(spec ~spec-form)
 449 |                    (set? spec-form) `(spec ~spec-form)
 450 |                    (nil? spec-form) nil ;; remove mapping
 451 | 
 452 |                    (c/or (list? spec-form) (seq? spec-form))
 453 |                    (let [explicated-form (explicate (ns-name *ns*) spec-form)
 454 |                          op (first explicated-form)]
 455 |                      (cond
 456 |                        (#{'fn 'fn* `c/fn} op) `(spec ~explicated-form)
 457 |                        (contains? (-> #'create-spec deref methods c/keys set) op) explicated-form
 458 |                        :else (throw (ex-info (str "Unable to def " k ", unknown spec op: " op)
 459 |                                       {:k k :form explicated-form}))))
 460 | 
 461 |                    :else
 462 |                    (throw (ex-info (str "Unable to def " k ", invalid spec definition: " (pr-str spec-form))
 463 |                             {:k k :form spec-form})))]
 464 |     `(register '~k ~spec-def)))
 465 | 
 466 | (defmacro with-gen
 467 |   "Takes a spec and a no-arg, generator-returning fn and returns a version of that spec that uses that generator"
 468 |   [spec gen-fn]
 469 |   `(resolve-spec '~(explicate (ns-name *ns*) `(with-gen ~spec ~gen-fn))))
 470 | 
 471 | (defmacro merge
 472 |   "Takes map-validating specs (e.g. 'keys' specs) and
 473 |   returns a spec that returns a conformed map satisfying all of the
 474 |   specs.  Unlike 'and', merge can generate maps satisfying the
 475 |   union of the predicates."
 476 |   [& pred-forms]
 477 |   `(resolve-spec '~(explicate (ns-name *ns*) `(merge ~@pred-forms))))
 478 | 
 479 | (defmacro every
 480 |   "takes a pred and validates collection elements against that pred.
 481 | 
 482 |   Note that 'every' does not do exhaustive checking, rather it samples
 483 |   *coll-check-limit* elements. Nor (as a result) does it do any
 484 |   conforming of elements. 'explain' will report at most *coll-error-limit*
 485 |   problems.  Thus 'every' should be suitable for potentially large
 486 |   collections.
 487 | 
 488 |   Takes several kwargs options that further constrain the collection:
 489 | 
 490 |   :kind - a pred that the collection type must satisfy, e.g. vector?
 491 |         (default nil) Note that if :kind is specified and :into is
 492 |         not, this pred must generate in order for every to generate.
 493 |   :count - specifies coll has exactly this count (default nil)
 494 |   :min-count, :max-count - coll has count (<= min-count count max-count) (defaults nil)
 495 |   :distinct - all the elements are distinct (default nil)
 496 | 
 497 |   And additional args that control gen
 498 | 
 499 |   :gen-max - the maximum coll size to generate (default 20)
 500 |   :into - one of [], (), {}, #{} - the default collection to generate into
 501 |       (default: empty coll as generated by :kind pred if supplied, else [])
 502 | 
 503 |   Optionally takes :gen generator-fn, which must be a fn of no args that
 504 |   returns a test.check generator
 505 | 
 506 |   See also - coll-of, every-kv"
 507 |   [pred & {:keys [::describe] :as opts}]
 508 |   (let [nopts (dissoc opts ::describe)
 509 |         d (c/or describe `(every ~pred ~@(mapcat identity opts)))]
 510 |     `(resolve-spec '~(explicate (ns-name *ns*) `(every ~pred ::describe ~d ~@(mapcat identity nopts))))))
 511 | 
 512 | (defmacro every-kv
 513 |   "like 'every' but takes separate key and val preds and works on associative collections.
 514 | 
 515 |   Same options as 'every', :into defaults to {}
 516 | 
 517 |   See also - map-of"
 518 |   [kpred vpred & opts]
 519 |   `(resolve-spec '~(explicate (ns-name *ns*) `(every-kv ~kpred ~vpred ~@opts))))
 520 | 
 521 | (defmacro coll-of
 522 |   "Returns a spec for a collection of items satisfying pred. Unlike
 523 |   'every', coll-of will exhaustively conform every value.
 524 | 
 525 |   Same options as 'every'. conform will produce a collection
 526 |   corresponding to :into if supplied, else will match the input collection,
 527 |   avoiding rebuilding when possible.
 528 | 
 529 |   See also - every, map-of"
 530 |   [pred & opts]
 531 |   `(resolve-spec '~(explicate (ns-name *ns*) `(coll-of ~pred ~@opts))))
 532 | 
 533 | (defmacro map-of
 534 |   "Returns a spec for a map whose keys satisfy kpred and vals satisfy
 535 |   vpred. Unlike 'every-kv', map-of will exhaustively conform every
 536 |   value.
 537 | 
 538 |   Same options as 'every', :kind defaults to map?, with the addition of:
 539 | 
 540 |   :conform-keys - conform keys as well as values (default false)
 541 | 
 542 |   See also - every-kv"
 543 |   [kpred vpred & opts]
 544 |   `(resolve-spec '~(explicate (ns-name *ns*) `(map-of ~kpred ~vpred ~@opts))))
 545 | 
 546 | (defmacro *
 547 |   "Returns a regex op that matches zero or more values matching
 548 |   pred. Produces a vector of matches iff there is at least one match"
 549 |   [pred-form]
 550 |   `(resolve-spec '~(explicate (ns-name *ns*) `(* ~pred-form))))
 551 | 
 552 | (defmacro +
 553 |   "Returns a regex op that matches one or more values matching
 554 |   pred. Produces a vector of matches"
 555 |   [pred-form]
 556 |   `(resolve-spec '~(explicate (ns-name *ns*) `(+ ~pred-form))))
 557 | 
 558 | (defmacro ?
 559 |   "Returns a regex op that matches zero or one value matching
 560 |   pred. Produces a single value (not a collection) if matched."
 561 |   [pred-form]
 562 |   `(resolve-spec '~(explicate (ns-name *ns*) `(? ~pred-form))))
 563 | 
 564 | (defmacro alt
 565 |   "Takes key+pred pairs, e.g.
 566 | 
 567 |   (s/alt :even even? :small #(< % 42))
 568 | 
 569 |   Returns a regex op that returns a map entry containing the key of the
 570 |   first matching pred and the corresponding value. Thus the
 571 |   'key' and 'val' functions can be used to refer generically to the
 572 |   components of the tagged return"
 573 |   [& key-pred-forms]
 574 |   `(resolve-spec '~(explicate (ns-name *ns*) `(alt ~@key-pred-forms))))
 575 | 
 576 | (defmacro cat
 577 |   "Takes key+pred pairs, e.g.
 578 | 
 579 |   (s/cat :e even? :o odd?)
 580 | 
 581 |   Returns a regex op that matches (all) values in sequence, returning a map
 582 |   containing the keys of each pred and the corresponding value."
 583 |   [& key-pred-forms]
 584 |   `(resolve-spec '~(explicate (ns-name *ns*) `(cat ~@key-pred-forms))))
 585 | 
 586 | (defmacro &
 587 |   "takes a regex op re, and predicates. Returns a regex-op that consumes
 588 |   input as per re but subjects the resulting value to the
 589 |   conjunction of the predicates, and any conforming they might perform."
 590 |   [re & preds]
 591 |   `(resolve-spec '~(explicate (ns-name *ns*) `(clojure.alpha.spec/& ~re ~@preds))))
 592 | 
 593 | (defmacro nest
 594 |   "takes a regex op and returns a non-regex op that describes a nested
 595 |   sequential collection."
 596 |   [re]
 597 |   `(resolve-spec '~(explicate (ns-name *ns*) `(nest ~re))))
 598 | 
 599 | (defmacro conformer
 600 |   "takes a predicate function with the semantics of conform i.e. it should return either a
 601 |   (possibly converted) value or :clojure.alpha.spec/invalid, and returns a
 602 |   spec that uses it as a predicate/conformer. Optionally takes a
 603 |   second fn that does unform of result of first"
 604 |   ([f] `(resolve-spec '~(explicate (ns-name *ns*) `(conformer ~f))))
 605 |   ([f unf] `(resolve-spec '~(explicate (ns-name *ns*) `(conformer ~f ~unf)))))
 606 | 
 607 | (defmacro fspec
 608 |   "takes :args :ret and (optional) :fn kwargs whose values are preds
 609 |   and returns a spec whose conform/explain take a fn and validates it
 610 |   using generative testing. The conformed value is always the fn itself.
 611 | 
 612 |   See 'fdef' for a single operation that creates an fspec and
 613 |   registers it, as well as a full description of :args, :ret and :fn
 614 | 
 615 |   fspecs can generate functions that validate the arguments and
 616 |   fabricate a return value compliant with the :ret spec, ignoring
 617 |   the :fn spec if present.
 618 | 
 619 |   Optionally takes :gen generator-fn, which must be a fn of no args
 620 |   that returns a test.check generator."
 621 |   [& opts]
 622 |   `(resolve-spec '~(explicate (ns-name *ns*) `(fspec ~@opts))))
 623 | 
 624 | (defn- macroexpand-check
 625 |   [v args]
 626 |   (let [fn-spec (get-spec v)]
 627 |     (when-let [arg-spec (:args fn-spec)]
 628 |       (when (invalid? (conform arg-spec args))
 629 |         (let [ed (assoc (explain-data* arg-spec []
 630 |                                        (if-let [name (spec-name arg-spec)] [name] []) [] args nil nil)
 631 |                    ::sa/args args)]
 632 |           (throw (ex-info
 633 |                    (str "Call to " (symbol v) " did not conform to spec.")
 634 |                    ed)))))))
 635 | 
 636 | (defmacro fdef
 637 |   "Takes a symbol naming a function, and one or more of the following:
 638 | 
 639 |   :args A regex spec for the function arguments as they were a list to be
 640 |     passed to apply - in this way, a single spec can handle functions with
 641 |     multiple arities
 642 |   :ret A spec for the function's return value
 643 |   :fn A spec of the relationship between args and ret - the
 644 |     value passed is {:args conformed-args :ret conformed-ret} and is
 645 |     expected to contain predicates that relate those values
 646 | 
 647 |   Qualifies fn-sym with resolve, or using *ns* if no resolution found.
 648 |   Registers an fspec in the global registry, where it can be retrieved
 649 |   by calling get-spec with the var or fully-qualified symbol.
 650 | 
 651 |   Once registered, function specs are included in doc, checked by
 652 |   instrument, tested by the runner clojure.alpha.spec.test/check, and (if
 653 |   a macro) used to explain errors during macroexpansion.
 654 | 
 655 |   Note that :fn specs require the presence of :args and :ret specs to
 656 |   conform values, and so :fn specs will be ignored if :args or :ret
 657 |   are missing.
 658 | 
 659 |   Returns the qualified fn-sym.
 660 | 
 661 |   For example, to register function specs for the symbol function:
 662 | 
 663 |   (s/fdef clojure.core/symbol
 664 |     :args (s/alt :separate (s/cat :ns string? :n string?)
 665 |                  :str string?
 666 |                  :sym symbol?)
 667 |     :ret symbol?)"
 668 |   [fn-sym & specs]
 669 |   `(clojure.alpha.spec/def ~fn-sym (clojure.alpha.spec/fspec ~@specs)))
 670 | 
 671 | (defmacro keys
 672 |   "Creates and returns a map validating spec. :req and :opt are both
 673 |   vectors of namespaced-qualified keywords. The validator will ensure
 674 |   the :req keys are present. The :opt keys serve as documentation and
 675 |   may be used by the generator.
 676 | 
 677 |   The :req key vector supports 'and' and 'or' for key groups:
 678 | 
 679 |   (s/keys :req [::x ::y (or ::secret (and ::user ::pwd))] :opt [::z])
 680 | 
 681 |   There are also -un versions of :req and :opt. These allow
 682 |   you to connect unqualified keys to specs.  In each case, fully
 683 |   qualified keywords are passed, which name the specs, but unqualified
 684 |   keys (with the same name component) are expected and checked at
 685 |   conform-time, and generated during gen:
 686 | 
 687 |   (s/keys :req-un [:my.ns/x :my.ns/y])
 688 | 
 689 |   The above says keys :x and :y are required, and will be validated
 690 |   and generated by specs (if they exist) named :my.ns/x :my.ns/y
 691 |   respectively.
 692 | 
 693 |   In addition, the values of *all* namespace-qualified keys will be validated
 694 |   (and possibly destructured) by any registered specs. Note: there is
 695 |   no support for inline value specification, by design.
 696 | 
 697 |   Optionally takes :gen generator-fn, which must be a fn of no args that
 698 |   returns a test.check generator."
 699 |   [& ks]
 700 |   `(resolve-spec '~(explicate (ns-name *ns*) `(keys ~@ks))))
 701 | 
 702 | (defmacro select
 703 |   "Takes a keyset and a selection pattern and returns a spec that
 704 |   validates a map. The keyset specifies what keys may be in the map
 705 |   and the specs to use if the keys are unqualified. The selection
 706 |   pattern indicates what keys must be in the map, and any nested
 707 |   maps."
 708 |   [keyset selection]
 709 |   `(resolve-spec '~(explicate (ns-name *ns*) `(select ~keyset ~selection))))
 710 | 
 711 | (defmacro multi-spec
 712 |   "Takes the name of a spec/predicate-returning multimethod and a
 713 |   tag-restoring keyword or fn (retag).  Returns a spec that when
 714 |   conforming or explaining data will pass it to the multimethod to get
 715 |   an appropriate spec. You can e.g. use multi-spec to dynamically and
 716 |   extensibly associate specs with 'tagged' data (i.e. data where one
 717 |   of the fields indicates the shape of the rest of the structure).
 718 | 
 719 |   (defmulti mspec :tag)
 720 | 
 721 |   The methods should ignore their argument and return a predicate/spec:
 722 |   (defmethod mspec :int [_] (s/keys :req-un [::tag ::i]))
 723 | 
 724 |   retag is used during generation to retag generated values with
 725 |   matching tags. retag can either be a keyword, at which key the
 726 |   dispatch-tag will be assoc'ed, or a fn of generated value and
 727 |   dispatch-tag that should return an appropriately retagged value.
 728 | 
 729 |   Note that because the tags themselves comprise an open set,
 730 |   the tag key spec cannot enumerate the values, but can e.g.
 731 |   test for keyword?.
 732 | 
 733 |   Note also that the dispatch values of the multimethod will be
 734 |   included in the path, i.e. in reporting and gen overrides, even
 735 |   though those values are not evident in the spec.
 736 | "
 737 |   [mm retag]
 738 |   `(resolve-spec '~(explicate (ns-name *ns*) `(multi-spec ~mm ~retag))))
 739 | 
 740 | (defmacro tuple
 741 |   "takes one or more preds and returns a spec for a tuple, a vector
 742 |   where each element conforms to the corresponding pred. Each element
 743 |   will be referred to in paths using its ordinal."
 744 |   [& preds]
 745 |   (c/assert (not (empty? preds)))
 746 |   `(resolve-spec '~(explicate (ns-name *ns*) `(tuple ~@preds))))
 747 | 
 748 | (defmacro or
 749 |   "Takes key+pred pairs, e.g.
 750 | 
 751 |   (s/or :even even? :small #(< % 42))
 752 | 
 753 |   Returns a destructuring spec that returns a map entry containing the
 754 |   key of the first matching pred and the corresponding value. Thus the
 755 |   'key' and 'val' functions can be used to refer generically to the
 756 |   components of the tagged return."
 757 |   [& key-pred-forms]
 758 |   (c/assert (c/and (even? (count key-pred-forms)) (->> key-pred-forms (partition 2) (map first) (every? keyword?)))
 759 |             "spec/or expects k1 p1 k2 p2..., where ks are keywords")
 760 |   `(resolve-spec '~(explicate (ns-name *ns*) `(or ~@key-pred-forms))))
 761 | 
 762 | (defmacro and
 763 |   "Takes predicate/spec-forms, e.g.
 764 | 
 765 |   (s/and int? even? #(< % 42))
 766 | 
 767 |   Returns a spec that returns the conformed value. Successive
 768 |   conformed values propagate through rest of predicates."
 769 |   [& pred-forms]
 770 |   `(resolve-spec '~(explicate (ns-name *ns*) `(and ~@pred-forms))))
 771 | 
 772 | (defmacro and-
 773 |   "Takes predicate/spec-forms, e.g.
 774 | 
 775 |   (s/and- (s/cat :i int?) #(pos? (first %)))
 776 | 
 777 |   Returns a spec that validates all preds on and returns the conformed value of
 778 |   the first pred. Conformed values are NOT propagated through rest of predicates."
 779 |   [& pred-forms]
 780 |   `(resolve-spec '~(explicate (ns-name *ns*) `(and- ~@pred-forms))))
 781 | 
 782 | 
 783 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; non-primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 784 | 
 785 | (defmacro keys*
 786 |   "takes the same arguments as spec/keys and returns a regex op that matches sequences of key/values,
 787 |   converts them into a map, and conforms that map with a corresponding
 788 |   spec/keys call:
 789 | 
 790 |   user=> (s/conform (s/keys :req-un [::a ::c]) {:a 1 :c 2})
 791 |   {:a 1, :c 2}
 792 |   user=> (s/conform (s/keys* :req-un [::a ::c]) [:a 1 :c 2])
 793 |   {:a 1, :c 2}
 794 | 
 795 |   the resulting regex op can be composed into a larger regex:
 796 | 
 797 |   user=> (s/conform (s/cat :i1 integer? :m (s/keys* :req-un [::a ::c]) :i2 integer?) [42 :a 1 :c 2 :d 4 99])
 798 |   {:i1 42, :m {:a 1, :c 2, :d 4}, :i2 99}"
 799 |   [& kspecs]
 800 |   `(resolve-spec '~(explicate (ns-name *ns*) `(keys* ~@kspecs))))
 801 | 
 802 | (defmacro nonconforming
 803 |   "takes a spec and returns a spec that has the same properties except
 804 |   'conform' returns the original (not the conformed) value."
 805 |   [spec]
 806 |   `(resolve-spec '~(explicate (ns-name *ns*) `(nonconforming ~spec))))
 807 | 
 808 | (defmacro nilable
 809 |   "returns a spec that accepts nil and values satisfying pred"
 810 |   [pred]
 811 |   `(resolve-spec '~(explicate (ns-name *ns*) `(nilable ~pred))))
 812 | 
 813 | (defn exercise
 814 |   "generates a number (default 10) of values compatible with spec and maps conform over them,
 815 |   returning a sequence of [val conformed-val] tuples. Optionally takes
 816 |   a generator overrides map as per gen"
 817 |   ([spec] (exercise spec 10))
 818 |   ([spec n] (exercise spec n nil))
 819 |   ([spec n overrides]
 820 |      (map #(vector % (conform spec %)) (gen/sample (gen spec overrides) n))))
 821 | 
 822 | (defn exercise-fn
 823 |   "exercises the fn named by sym (a symbol) by applying it to
 824 |   n (default 10) generated samples of its args spec. When fspec is
 825 |   supplied its arg spec is used, and sym-or-f can be a fn.  Returns a
 826 |   sequence of tuples of [args ret]. "
 827 |   ([sym] (exercise-fn sym 10))
 828 |   ([sym n] (exercise-fn sym n (get-spec sym)))
 829 |   ([sym-or-f n fspec]
 830 |      (let [f (if (symbol? sym-or-f) (resolve sym-or-f) sym-or-f)]
 831 |        (if-let [arg-spec (c/and fspec (:args fspec))]
 832 |          (for [args (gen/sample (gen arg-spec) n)]
 833 |            [args (apply f args)])
 834 |          (throw (Exception. "No :args spec found, can't generate"))))))
 835 | 
 836 | (defn inst-in-range?
 837 |   "Return true if inst at or after start and before end"
 838 |   [start end inst]
 839 |   (c/and (inst? inst)
 840 |          (let [t (inst-ms inst)]
 841 |            (c/and (<= (inst-ms start) t) (< t (inst-ms end))))))
 842 | 
 843 | (defn int-in-range?
 844 |   "Return true if start <= val, val < end and val is a fixed
 845 |   precision integer."
 846 |   [start end val]
 847 |   (c/and (int? val) (<= start val) (< val end)))
 848 | 
 849 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; assert ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 850 | (defonce
 851 |   ^{:dynamic true
 852 |     :doc "If true, compiler will enable spec asserts, which are then
 853 | subject to runtime control via check-asserts? If false, compiler
 854 | will eliminate all spec assert overhead. See 'assert'.
 855 | 
 856 | Initially set to boolean value of clojure.spec.compile-asserts
 857 | system property. Defaults to true."}
 858 |   *compile-asserts*
 859 |   (not= "false" (System/getProperty "clojure.spec.compile-asserts")))
 860 | 
 861 | (defn check-asserts?
 862 |   "Returns the value set by check-asserts."
 863 |   []
 864 |   clojure.lang.RT/checkSpecAsserts)
 865 | 
 866 | (defn check-asserts
 867 |   "Enable or disable spec asserts that have been compiled
 868 | with '*compile-asserts*' true.  See 'assert'.
 869 | 
 870 | Initially set to boolean value of clojure.spec.check-asserts
 871 | system property. Defaults to false."
 872 |   [flag]
 873 |   (set! (. clojure.lang.RT checkSpecAsserts) flag))
 874 | 
 875 | (defn assert*
 876 |   "Do not call this directly, use 'assert'."
 877 |   [spec x]
 878 |   (if (valid? spec x)
 879 |     x
 880 |     (let [ed (c/merge (assoc (explain-data* spec [] [] [] x nil nil)
 881 |                         ::sa/failure :assertion-failed))]
 882 |       (throw (ex-info
 883 |               (str "Spec assertion failed\n" (with-out-str (explain-out ed)))
 884 |               ed)))))
 885 | 
 886 | (defmacro assert
 887 |   "spec-checking assert expression. Returns x if x is valid? according
 888 | to spec, else throws an ex-info with explain-data plus ::failure of
 889 | :assertion-failed.
 890 | 
 891 | Can be disabled at either compile time or runtime:
 892 | 
 893 | If *compile-asserts* is false at compile time, compiles to x. Defaults
 894 | to value of 'clojure.spec.compile-asserts' system property, or true if
 895 | not set.
 896 | 
 897 | If (check-asserts?) is false at runtime, always returns x. Defaults to
 898 | value of 'clojure.spec.check-asserts' system property, or false if not
 899 | set. You can toggle check-asserts? with (check-asserts bool)."
 900 |   [spec x]
 901 |   (if *compile-asserts*
 902 |     `(if clojure.lang.RT/checkSpecAsserts
 903 |        (assert* ~spec ~x)
 904 |        ~x)
 905 |     x))
 906 | 
 907 | (defn ^:skip-wiki sig-map
 908 |   "Do not call directly."
 909 |   [sig vals]
 910 |   (let [locals (->> sig
 911 |                     (tree-seq coll? identity)
 912 |                     (filter #(c/and (symbol? %) (not= '& %)))
 913 |                     distinct
 914 |                     vec)]
 915 |     (zipmap locals (eval `(let [~sig ~(vec vals)] ~locals)))))
 916 | 
 917 | (defn ^:skip-wiki op-spec
 918 |   "Do not call directly, use `defop`"
 919 |   [sp form gfn]
 920 |   (reify
 921 |     protocols/Spec
 922 |     (conform* [_ x settings-key settings] (protocols/conform* @sp x settings-key settings))
 923 |     (unform* [_ x] (unform @sp x))
 924 |     (explain* [_ path via in x settings-key settings]
 925 |       (protocols/explain* @sp path via in x settings-key settings))
 926 |     (gen* [_ _ _ _] (if gfn (gfn) (gen @sp)))
 927 |     (with-gen* [_ gfn] (op-spec sp form gfn))
 928 |     (describe* [_] form)))
 929 | 
 930 | (defmacro defop
 931 |   "Defines a new spec op with op-name defined by the form. Defines a macro for op-name with docstring that
 932 |   expands to a call to resolve-spec with the explicated form. args are replaced in the form. Creates a create-spec
 933 |   method implementation for op-name that creates a spec whose body is form.
 934 | 
 935 |   Opts allowed:
 936 |    :gen - takes a no-arg function returning a generator to use"
 937 |   {:arglists '([op-name doc-string? opts? [params*] form])}
 938 |   [op-name & op-tail]
 939 |   (let [form (last op-tail)
 940 |         opts (butlast op-tail)
 941 |         [doc args opts] (if (string? (first opts))
 942 |                           [(first opts) (second opts) (nthrest opts 2)]
 943 |                           [nil (first opts) (rest opts)])
 944 |         _ (c/assert (even? (count opts)) "defop options should be keyword/value pairs")
 945 |         {:keys [gen]} opts
 946 |         ns-name (ns-name *ns*)
 947 |         op (symbol (name ns-name) (name op-name))]
 948 |     `(do
 949 |        (defmethod expand-spec '~op
 950 |          [[~'_ ~'& ~'sargs]]
 951 |          (let [os# '~op]
 952 |            {:clojure.spec/op os#
 953 |             :args ~'sargs}))
 954 |        (defmethod create-spec '~op
 955 |          [~'mform]
 956 |          (let [a# (:args ~'mform)
 957 |                m# (sig-map '~args a#) ;; map of arg name to arg value
 958 |                sp# (delay (resolve-spec (explicate '~ns-name (walk/postwalk (fn [x#] (get m# x# x#)) '~form))))]
 959 |            (op-spec sp# (cons '~op a#) (resolve-fn (walk/postwalk (fn [x#] (get m# x# x#)) '~gen)))))
 960 |        (defmacro ~op-name
 961 |          ~@(if doc [doc] [])       ;; docstring
 962 |          {:arglists (list '~args)} ;; metadata with arglists
 963 |          [~'& ~'sargs]
 964 |          (list `resolve-spec (list `explicate (list `quote '~ns-name) (list `quote (cons '~op ~'sargs))))))))
 965 | 
 966 | ;; Load the spec op implementations
 967 | (load "/clojure/alpha/spec/impl")
 968 | 
 969 | ;; Derived ops
 970 | 
 971 | (defop inst-in
 972 |   "Returns a spec that validates insts in the range from start
 973 |   (inclusive) to end (exclusive)."
 974 |   [start end]
 975 |   :gen #(clojure.alpha.spec.gen/fmap (fn [^long d] (java.util.Date. d))
 976 |          (clojure.alpha.spec.gen/large-integer* {:min (inst-ms start) :max (inst-ms end)}))
 977 |   (and inst? #(inst-in-range? start end %)))
 978 | 
 979 | (defop int-in
 980 |   "Returns a spec that validates fixed precision integers in the
 981 |   range from start (inclusive) to end (exclusive)."
 982 |   [start end]
 983 |   :gen #(clojure.alpha.spec.gen/large-integer* {:min start :max (dec end)})
 984 |   (and int? #(int-in-range? start end %)))
 985 | 
 986 | (defop double-in
 987 |   "Specs a 64-bit floating point number. Options:
 988 | 
 989 |     :infinite? - whether +/- infinity allowed (default true)
 990 |     :NaN?      - whether NaN allowed (default true)
 991 |     :min       - minimum value (inclusive, default none)
 992 |     :max       - maximum value (inclusive, default none)"
 993 |   [& {:keys [infinite? NaN? min max :as m]}]
 994 |   :gen #(clojure.alpha.spec.gen/double* m)
 995 |   (and double?
 996 |        #(if-not infinite? (not (Double/isInfinite %)))
 997 |        #(if-not NaN? (not (Double/isNaN %)))
 998 |        #(if min (<= min %) true)
 999 |        #(if max (<= % max) true)))
1000 | 
1001 | (defmacro defcompop
1002 |   "Defines a new composite spec with op-name and args same as spec-op.
1003 |   The new spec takes the same args as spec-op, and also ensures the preds
1004 |   are satisfied."
1005 |   {:arglists '([op-name doc-string? spec-op preds+])}
1006 |   [op-name & tail]
1007 |   (let [[doc spec-op & preds] (if (string? (first tail)) tail (cons nil tail))
1008 |         ns-name (ns-name *ns*)
1009 |         op (symbol (name ns-name) (name op-name))]
1010 |     (c/assert (pos? (count preds)) "defcompop should have at least one pred")
1011 |     `(do
1012 |        (defmethod expand-spec '~op
1013 |          [[~'_ ~'& ~'sargs]]
1014 |          (let [os# '~op]
1015 |            {:clojure.spec/op os#
1016 |             :primary '~(explicate ns-name spec-op)
1017 |             :preds '~(explicate ns-name preds)
1018 |             :args ~'sargs}))
1019 |        (defmethod create-spec '~op
1020 |          [~'mform]
1021 |          (let [primary# (:primary ~'mform)
1022 |                preds# (:preds ~'mform)
1023 |                a# (:args ~'mform)
1024 |                comp-spec# (concat (list 'clojure.alpha.spec/and- (cons '~(explicate ns-name spec-op) a#)) preds#)]
1025 |            (resolve-spec comp-spec#)))
1026 |        (defmacro ~op-name
1027 |          ~@(if doc [doc] [])
1028 |          {:arglists '~(:arglists (meta (find-var (explicate ns-name spec-op))))}
1029 |          [~'& ~'sargs]
1030 |          (list `resolve-spec (list `explicate (list `quote '~ns-name) (list `quote (cons '~op ~'sargs))))))))
1031 | 
1032 | (defcompop catv "Like s/cat, but constrain to only vectors" cat vector?)
1033 | (defcompop cats "Like s/cat, but constrain to only seqs" cat seq?)
1034 | 


--------------------------------------------------------------------------------
/src/main/clojure/clojure/alpha/spec/impl.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 ^{:skip-wiki true}
  10 |   clojure.alpha.spec.impl
  11 |   (:require
  12 |     [clojure.alpha.spec :as s]
  13 |     [clojure.alpha.spec.protocols :as protocols
  14 |      :refer [Spec conform* unform* explain* gen* with-gen* describe*
  15 |              Schema keyspecs*
  16 |              Select]]
  17 |     [clojure.alpha.spec.gen :as gen]
  18 |     [clojure.set :as set]
  19 |     [clojure.walk :as walk]))
  20 | 
  21 | (set! *warn-on-reflection* true)
  22 | 
  23 | (defn- resolve-form
  24 |   [form]
  25 |   (if (keyword? form)
  26 |     form
  27 |     (-> form s/resolve-spec s/form)))
  28 | 
  29 | (defn- resolve-forms
  30 |   [forms]
  31 |   (map resolve-form forms))
  32 | 
  33 | (defn- maybe-spec
  34 |   "spec-or-k must be a spec, regex or resolvable kw/sym, else returns nil."
  35 |   [spec-or-k]
  36 |   (let [s (or (and (ident? spec-or-k) (#'s/reg-resolve spec-or-k))
  37 |                 (s/spec? spec-or-k)
  38 |                 (s/regex? spec-or-k)
  39 |                 nil)]
  40 |     (if (s/regex? s)
  41 |       (#'s/with-name s (#'s/spec-name s))
  42 |       s)))
  43 | 
  44 | (defn- the-spec
  45 |   "spec-or-k must be a spec, regex or kw/sym, else returns nil. Throws if unresolvable kw/sym"
  46 |   [spec-or-k]
  47 |   (or (maybe-spec spec-or-k)
  48 |       (when (ident? spec-or-k)
  49 |         (throw (Exception. (str "Unable to resolve spec: " spec-or-k))))))
  50 | 
  51 | (defn- fn-impl
  52 |   [form gfn]
  53 |   (let [pred (s/resolve-fn form)]
  54 |     (reify
  55 |       Spec
  56 |       (conform* [_ x settings-key settings]
  57 |         (if (pred x) x ::s/invalid))
  58 |       (unform* [_ x] x)
  59 |       (explain* [_ path via in x settings-key settings]
  60 |         (when-not (pred x)
  61 |           [{:path path :pred (#'s/unfn form) :val x :via via :in in}]))
  62 |       (gen* [_ _ _ _] (if gfn
  63 |                         (gfn)
  64 |                         (gen/gen-for-pred pred)))
  65 |       (with-gen* [_ gfn] (fn-impl form gfn))
  66 |       (describe* [_] (#'s/unfn form)))))
  67 | 
  68 | (defmethod s/expand-spec 'fn*
  69 |   [[_ & fn-tail]]
  70 |   {:clojure.spec/op 'fn*
  71 |    :fn-tail (vec fn-tail)})
  72 | 
  73 | (defmethod s/create-spec 'fn*
  74 |   [{:keys [fn-tail]}]
  75 |   (fn-impl `(fn* ~@fn-tail) nil))
  76 | 
  77 | (defmethod s/expand-spec `fn
  78 |   [[_ & fn-tail]]
  79 |   {:clojure.spec/op `fn
  80 |    :fn-tail (vec fn-tail)})
  81 | 
  82 | (defmethod s/create-spec `fn
  83 |   [{:keys [fn-tail]}]
  84 |   (fn-impl `(fn ~@fn-tail) nil))
  85 | 
  86 | (defmethod s/expand-spec 'fn
  87 |   [[_ & fn-tail]]
  88 |   {:clojure.spec/op 'fn
  89 |    :fn-tail (vec fn-tail)})
  90 | 
  91 | (defmethod s/create-spec 'fn
  92 |   [{:keys [fn-tail]}]
  93 |   (fn-impl `(fn ~@fn-tail) nil))
  94 | 
  95 | (defmethod s/expand-spec `s/with-gen
  96 |   [[_ spec gen-fn]]
  97 |   {:clojure.spec/op `s/with-gen
  98 |    :spec spec
  99 |    :gen-fn gen-fn})
 100 | 
 101 | (defmethod s/create-spec `s/with-gen
 102 |   [{:keys [spec gen-fn]}]
 103 |   (let [spec (s/resolve-spec spec)
 104 |         g (s/resolve-fn gen-fn)]
 105 |     (if (s/regex? spec)
 106 |       (assoc spec ::gfn g)
 107 |       (protocols/with-gen* spec g))))
 108 | 
 109 | (defn- conformer-impl
 110 |   [f-form unf-form gfn]
 111 |   (let [f (s/resolve-fn f-form)
 112 |         unf (when unf-form (s/resolve-fn unf-form))]
 113 |     (reify
 114 |       protocols/Spec
 115 |       (conform* [_ x settings-key settings] (f x))
 116 |       (unform* [_ x] (if unf
 117 |                        (unf x)
 118 |                        (throw (IllegalStateException. "no unform fn for conformer"))))
 119 |       (explain* [_ path via in x settings-key settings]
 120 |         (when (s/invalid? (f x))
 121 |           [{:path path :pred `(s/conformer ~f-form ~@(if unf-form (vector unf-form) nil)) :val x :via via :in in}]))
 122 |       (gen* [_ _ _ _] (if gfn (gfn) (gen/gen-for-pred f)))
 123 |       (with-gen* [_ gfn] (conformer-impl f-form unf-form gfn))
 124 |       (describe* [_] `(s/conformer ~f-form ~@(if unf-form (vector unf-form) nil))))))
 125 | 
 126 | (defmethod s/expand-spec `s/conformer
 127 |   [[_ f & [unf]]]
 128 |   (cond->
 129 |     {:clojure.spec/op `s/conformer
 130 |      :f f}
 131 |     unf (assoc :unf unf)))
 132 | 
 133 | (defmethod s/create-spec `s/conformer
 134 |   [{:keys [f unf]}]
 135 |   (conformer-impl f unf nil))
 136 | 
 137 | (declare cat-impl alt-impl rep-impl rep+impl maybe-impl amp-impl)
 138 | 
 139 | (defmethod s/expand-spec `s/*
 140 |   [[_ pred-form]]
 141 |   {:clojure.spec/op `s/*
 142 |    :spec pred-form})
 143 | 
 144 | (defmethod s/create-spec `s/*
 145 |   [{:keys [spec]}]
 146 |   (rep-impl spec (s/resolve-spec spec)))
 147 | 
 148 | (defmethod s/expand-spec `s/+
 149 |   [[_ pred-form]]
 150 |   {:clojure.spec/op `s/+
 151 |    :spec pred-form})
 152 | 
 153 | (defmethod s/create-spec `s/+
 154 |   [{:keys [spec]}]
 155 |   (rep+impl spec (s/resolve-spec spec)))
 156 | 
 157 | (defmethod s/expand-spec `s/?
 158 |   [[_ pred-form]]
 159 |   {:clojure.spec/op `s/?
 160 |    :spec pred-form})
 161 | 
 162 | (defmethod s/create-spec `s/?
 163 |   [{:keys [spec]}]
 164 |   (maybe-impl (s/resolve-spec spec) spec))
 165 | 
 166 | (defmethod s/expand-spec `s/alt
 167 |   [[_ & key-pred-forms]]
 168 |   (let [pairs (partition 2 key-pred-forms)
 169 |         keys (mapv first pairs)
 170 |         pred-forms (mapv second pairs)]
 171 |     {:clojure.spec/op `s/alt
 172 |      :keys keys
 173 |      :specs pred-forms}))
 174 | 
 175 | (defmethod s/create-spec `s/alt
 176 |   [{:keys [keys specs]}]
 177 |   (assert (and (= (count keys) (count specs))
 178 |             (every? keyword? keys))
 179 |     "alt expects k1 p1 k2 p2..., where ks are keywords")
 180 |   (alt-impl keys (mapv s/resolve-spec specs) specs))
 181 | 
 182 | (defmethod s/expand-spec `s/cat
 183 |   [[_ & key-pred-forms]]
 184 |   (let [pairs (partition 2 key-pred-forms)
 185 |         keys (mapv first pairs)
 186 |         pred-forms (mapv second pairs)]
 187 |     {:clojure.spec/op `s/cat
 188 |      :keys keys
 189 |      :specs pred-forms}))
 190 | 
 191 | (defmethod s/create-spec `s/cat
 192 |   [{:keys [keys specs]}]
 193 |   (assert (and (= (count keys) (count specs)) (every? keyword? keys)) "cat expects k1 p1 k2 p2..., where ks are keywords")
 194 |   (cat-impl keys (mapv s/resolve-spec specs) specs))
 195 | 
 196 | (defmethod s/expand-spec 'clojure.alpha.spec/&
 197 |   [[_ re & preds]]
 198 |   {:clojure.spec/op 'clojure.alpha.spec/&
 199 |    :spec re
 200 |    :preds (vec preds)})
 201 | 
 202 | (defmethod s/create-spec 'clojure.alpha.spec/&
 203 |   [{:keys [spec preds]}]
 204 |   (amp-impl (s/resolve-spec spec) spec (mapv s/resolve-spec preds) (mapv #'s/unfn preds)))
 205 | 
 206 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; impl ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 207 | (defn- recur-limit? [rmap id path k]
 208 |   (and (> (get rmap id) (::s/recursion-limit rmap))
 209 |          (contains? (set path) k)))
 210 | 
 211 | (defn- inck [m k]
 212 |   (assoc m k (inc (or (get m k) 0))))
 213 | 
 214 | (defn- dt
 215 |   ([pred x form] (dt pred x form nil))
 216 |   ([pred x form cpred?]
 217 |    (if pred
 218 |      (if-let [spec (the-spec pred)]
 219 |        (s/conform spec x)
 220 |        (if (ifn? pred)
 221 |          (if cpred?
 222 |            (pred x)
 223 |            (if (pred x) x ::s/invalid))
 224 |          (throw (Exception. (str (pr-str form) " is not a fn, expected predicate fn")))))
 225 |      x)))
 226 | 
 227 | (defn- pvalid?
 228 |   "internal helper function that returns true when x is valid for spec."
 229 |   ([pred x]
 230 |    (not (s/invalid? (dt pred x ::s/unknown))))
 231 |   ([pred x form]
 232 |    (not (s/invalid? (dt pred x form)))))
 233 | 
 234 | (defn- explain-1 [form pred path via in v settings-key settings]
 235 |   ;;(prn {:form form :pred pred :path path :in in :v v})
 236 |   (let [pred (maybe-spec pred)]
 237 |     (if (s/spec? pred)
 238 |       (explain* pred path (if-let [name (#'s/spec-name pred)] (conj via name) via) in v settings-key settings)
 239 |       [{:path path :pred form :val v :via via :in in}])))
 240 | 
 241 | (defn- explain-pred-list
 242 |   [forms preds path via in x settings-key settings]
 243 |   (loop [ret x
 244 |          [form & forms] forms
 245 |          [pred & preds] preds]
 246 |     (when pred
 247 |       (let [nret (dt pred ret form)]
 248 |         (if (s/invalid? nret)
 249 |           (explain-1 form pred path via in ret settings-key settings)
 250 |           (recur nret forms preds))))))
 251 | 
 252 | (declare or-k-gen and-k-gen)
 253 | 
 254 | (defn- k-gen
 255 |   "returns a generator for form f, which can be a keyword or a list
 256 |   starting with 'or or 'and."
 257 |   [f]
 258 |   (cond
 259 |     (keyword? f) (gen/return f)
 260 |     (= `or (first f)) (or-k-gen 1 (rest f))
 261 |     (= `and (first f)) (and-k-gen (rest f))))
 262 | 
 263 | (defn- or-k-gen
 264 |   "returns a tuple generator made up of generators for a random subset
 265 |   of min-count (default 0) to all elements in s."
 266 |   ([s] (or-k-gen 0 s))
 267 |   ([min-count s]
 268 |    (gen/bind (gen/tuple
 269 |                (gen/choose min-count (count s))
 270 |                (gen/shuffle (map k-gen s)))
 271 |              (fn [[n gens]]
 272 |                (apply gen/tuple (take n gens))))))
 273 | 
 274 | (defn- and-k-gen
 275 |   "returns a tuple generator made up of generators for every element
 276 |   in s."
 277 |   [s]
 278 |   (apply gen/tuple (map k-gen s)))
 279 | 
 280 | (defn- map-spec-impl
 281 |   "Do not call this directly, use 'keys'"
 282 |   [{:keys [req-un opt-un keys-pred pred-exprs opt-keys req-specs req req-keys opt-specs pred-forms opt gfn]
 283 |     :as argm}]
 284 |   (let [keys->specnames (zipmap (concat req-keys opt-keys) (concat req-specs opt-specs))
 285 |         id (java.util.UUID/randomUUID)]
 286 |     (reify
 287 |       Spec
 288 |       (conform* [_ m settings-key settings]
 289 |         (if (keys-pred m)
 290 |           (let [reg (s/registry)]
 291 |             (loop [ret m, [[k v] & ks :as keys] m]
 292 |               (if keys
 293 |                 (let [sname (keys->specnames k)]
 294 |                   (if-let [s (#'s/reg-resolve sname)]
 295 |                     (let [cv (conform* s v k settings)]
 296 |                       (if (s/invalid? cv)
 297 |                         ::s/invalid
 298 |                         (recur (if (identical? cv v) ret (assoc ret k cv))
 299 |                                ks)))
 300 |                     (recur ret ks)))
 301 |                 ret)))
 302 |           ::s/invalid))
 303 |       (unform* [_ m]
 304 |         (let [reg (s/registry)]
 305 |           (loop [ret m, [k & ks :as keys] (keys m)]
 306 |             (if keys
 307 |               (if (contains? reg (keys->specnames k))
 308 |                 (let [cv (get m k)
 309 |                       v (s/unform (keys->specnames k) cv)]
 310 |                   (recur (if (identical? cv v) ret (assoc ret k v))
 311 |                          ks))
 312 |                 (recur ret ks))
 313 |               ret))))
 314 |       (explain* [_ path via in x settings-key settings]
 315 |         (if-not (map? x)
 316 |           [{:path path :pred `map? :val x :via via :in in}]
 317 |           (let [reg (s/registry)]
 318 |             (apply concat
 319 |                    (when-let [probs (->> (map (fn [pred form] (when-not (pred x) form))
 320 |                                               pred-exprs pred-forms)
 321 |                                          (keep identity)
 322 |                                          seq)]
 323 |                      (map
 324 |                        #(identity {:path path :pred % :val x :via via :in in})
 325 |                        probs))
 326 |                    (map (fn [[k v]]
 327 |                           (when-not (or (not (contains? reg (keys->specnames k)))
 328 |                                           (pvalid? (keys->specnames k) v k))
 329 |                             (explain-1 (keys->specnames k) (keys->specnames k) (conj path k) via (conj in k) v k settings)))
 330 |                         (seq x))))))
 331 |       (gen* [_ overrides path rmap]
 332 |         (if gfn
 333 |           (gfn)
 334 |           (let [rmap (inck rmap id)
 335 |                 rgen (fn [k s] [k (#'s/gensub s overrides (conj path k) rmap k)])
 336 |                 ogen (fn [k s]
 337 |                        (when-not (recur-limit? rmap id path k)
 338 |                          [k (gen/delay (#'s/gensub s overrides (conj path k) rmap k))]))
 339 |                 reqs (map rgen req-keys req-specs)
 340 |                 opts (remove nil? (map ogen opt-keys opt-specs))]
 341 |             (when (every? identity (concat (map second reqs) (map second opts)))
 342 |               (gen/bind
 343 |                 (gen/tuple
 344 |                   (and-k-gen req)
 345 |                   (or-k-gen opt)
 346 |                   (and-k-gen req-un)
 347 |                   (or-k-gen opt-un))
 348 |                 (fn [[req-ks opt-ks req-un-ks opt-un-ks]]
 349 |                   (let [qks (flatten (concat req-ks opt-ks))
 350 |                         unqks (map (comp keyword name) (flatten (concat req-un-ks opt-un-ks)))]
 351 |                     (->> (into reqs opts)
 352 |                          (filter #((set (concat qks unqks)) (first %)))
 353 |                          (apply concat)
 354 |                          (apply gen/hash-map)))))))))
 355 |       (with-gen* [_ gfn] (map-spec-impl (assoc argm :gfn gfn)))
 356 |       (describe* [_] (cons `s/keys
 357 |                            (cond-> []
 358 |                                    req (conj :req req)
 359 |                                    opt (conj :opt opt)
 360 |                                    req-un (conj :req-un req-un)
 361 |                                    opt-un (conj :opt-un opt-un)))))))
 362 | 
 363 | (defmethod s/expand-spec `s/keys
 364 |   [[_ & opts]]
 365 |   (conj {:clojure.spec/op `s/keys} (apply hash-map opts)))
 366 | 
 367 | (defmethod s/create-spec `s/keys
 368 |   [{:keys [req req-un opt opt-un gen]}]
 369 |   (let [unk #(-> % name keyword)
 370 |         req-keys (filterv keyword? (flatten req))
 371 |         req-un-specs (filterv keyword? (flatten req-un))
 372 |         _ (assert (every? #(and (keyword? %) (namespace %)) (concat req-keys req-un-specs opt opt-un))
 373 |                     "all keys must be namespace-qualified keywords")
 374 |         req-specs (into req-keys req-un-specs)
 375 |         req-keys (into req-keys (map unk req-un-specs))
 376 |         opt-keys (into (vec opt) (map unk opt-un))
 377 |         opt-specs (into (vec opt) opt-un)
 378 |         gx (gensym)
 379 |         parse-req (fn [rk f]
 380 |                     (map (fn [x]
 381 |                            (if (keyword? x)
 382 |                              `(contains? ~gx ~(f x))
 383 |                              (walk/postwalk
 384 |                                (fn [y] (if (keyword? y) `(contains? ~gx ~(f y)) y))
 385 |                                x)))
 386 |                          rk))
 387 |         pred-exprs [`(map? ~gx)]
 388 |         pred-exprs (into pred-exprs (parse-req req identity))
 389 |         pred-exprs (into pred-exprs (parse-req req-un unk))
 390 |         keys-pred `(fn* [~gx] (and ~@pred-exprs))
 391 |         pred-exprs (mapv (fn [e] `(fn* [~gx] ~e)) pred-exprs)
 392 |         pred-forms (walk/postwalk #'s/res pred-exprs)]
 393 |     (map-spec-impl {:req req :opt opt :req-un req-un :opt-un opt-un
 394 |                     :req-keys req-keys :req-specs req-specs
 395 |                     :opt-keys opt-keys :opt-specs opt-specs
 396 |                     :pred-forms pred-forms
 397 |                     :pred-exprs (mapv s/resolve-fn pred-exprs)
 398 |                     :keys-pred (s/resolve-fn keys-pred)
 399 |                     :gfn (s/resolve-fn gen)})))
 400 | 
 401 | (defn- keyspecs
 402 |   [schema]
 403 |   (keyspecs* schema))
 404 | 
 405 | (defn- select?
 406 |   [spec-ref]
 407 |   (if-let [sp (if (qualified-keyword? spec-ref) (#'s/reg-resolve! spec-ref) spec-ref)]
 408 |     (satisfies? Select sp)
 409 |     false))
 410 | 
 411 | (defn- schema-impl
 412 |   [coll gfn]
 413 |   (let [coll (if (map? coll) [coll] coll)
 414 |         ks (filter keyword? coll)
 415 |         qks (zipmap ks ks)
 416 |         unq-map (apply merge (filter map? coll))
 417 |         unq-specs (map s/resolve-spec (vals unq-map))
 418 |         uqks (zipmap (keys unq-map) unq-specs)
 419 |         key-specs (merge uqks qks)
 420 |         lookup #(or (s/get-spec %) (get key-specs %))]
 421 |     ;; schemas cannot contain nested select specs
 422 |     (assert (every? #(if-let [sp (s/get-spec %)] (not (select? sp)) true) ks))
 423 |     (assert (every? #(not (select? %)) unq-specs))
 424 |     (reify
 425 |       Spec
 426 |       (conform* [_ x settings-key settings]
 427 |         (if (or (not (map? x))
 428 |               (and
 429 |                 (-> settings (get :closed) (contains? settings-key))
 430 |                 (not (set/subset? (-> x keys set) (set ks)))))
 431 |           ::s/invalid
 432 |           (loop [ret x ;; either conformed map or ::s/invalid
 433 |                  [[k v] & ks :as m] x]
 434 |             (if k
 435 |               (let [conformed (if-let [sp (lookup k)] (conform* sp v k settings) v)]
 436 |                 (if (s/invalid? conformed)
 437 |                   (recur ::s/invalid nil)
 438 |                   (recur (if-not (identical? v conformed) (assoc ret k conformed) ret) ks)))
 439 |               ret))))
 440 |       (unform* [_ x]
 441 |         (loop [ret x, [[k v] & ks :as m] x]
 442 |           (if-not m
 443 |             ret
 444 |             (if-let [sp (lookup k)]
 445 |               (let [uv (s/unform sp v)]
 446 |                 (recur (if (identical? uv v) ret (assoc ret k uv)) ks))
 447 |               (recur ret ks)))))
 448 |       (explain* [_ path via in x settings-key settings]
 449 |         (if (not (map? x))
 450 |           [{:path path :pred `map? :val x :via via :in in}]
 451 |           (if (and (-> settings (get :closed) (contains? settings-key))
 452 |                 (not (set/subset? (-> x keys set) (set ks))))
 453 |             (let [form `(fn [~'%] (set/subset? (set (keys ~'%)) ~(set ks)))]
 454 |               [{:path path :pred form :val x :via via :in in}])
 455 |             (reduce-kv
 456 |               (fn [p k v]
 457 |                 (if-let [sp (lookup k)]
 458 |                   (into p (explain-1 (s/form sp) sp (conj path k) via (conj in k) v k settings))
 459 |                   p))
 460 |               [] x))))
 461 |       (gen* [_ overrides path rmap]
 462 |         (if gfn
 463 |           (gfn)
 464 |           (let [ogen (fn [k s]
 465 |                        [k (gen/delay (#'s/gensub s overrides (conj path k) rmap k))])
 466 |                 opt-kset (keys key-specs)
 467 |                 opt-specs (->> opt-kset (map lookup) (remove nil?))
 468 |                 opts (remove nil? (map ogen opt-kset opt-specs))]
 469 |             (when (every? identity (map second opts))
 470 |               (gen/bind
 471 |                 (or-k-gen opt-kset)
 472 |                 (fn [opt-ks]
 473 |                   (let [qks (flatten opt-ks)]
 474 |                     (->> opts
 475 |                          (filter #((set qks) (first %)))
 476 |                          (apply concat)
 477 |                          (apply gen/hash-map)))))))))
 478 |       (with-gen* [_ gfn] (schema-impl coll gfn))
 479 |       (describe* [_] `(s/schema ~coll))
 480 | 
 481 |       Schema
 482 |       (keyspecs* [_] key-specs))))
 483 | 
 484 | (defmethod s/expand-spec `s/schema
 485 |   [[_ coll]]
 486 |   {:clojure.spec/op `s/schema
 487 |    :schema coll})
 488 | 
 489 | (defmethod s/create-spec `s/schema
 490 |   [{:keys [schema]}]
 491 |   (schema-impl schema nil))
 492 | 
 493 | (defn- union-impl
 494 |   [schemas gfn]
 495 |   (let [ks (->> schemas (map s/schema*) (map keyspecs) (apply merge))
 496 |         qk (filterv qualified-keyword? (keys ks))
 497 |         ukv (reduce-kv (fn [m k v]
 498 |                          (if (simple-keyword? k)
 499 |                            (assoc m k (if (keyword? v) v (s/form v)))
 500 |                            m))
 501 |               {} ks)
 502 |         impl (schema-impl (if (seq ukv) (conj qk ukv) qk) nil)]
 503 |     (reify
 504 |       Spec
 505 |       (conform* [_ x settings-key settings] (conform* impl x settings-key settings))
 506 |       (unform* [_ x] (unform* impl x))
 507 |       (explain* [_ path via in x settings-key settings] (explain* impl path via in x settings-key settings))
 508 |       (gen* [_ overrides path rmap] (gen* impl overrides path rmap))
 509 |       (with-gen* [_ gfn] (union-impl schemas gfn))
 510 |       (describe* [_] `(s/union ~@schemas))
 511 | 
 512 |       Schema
 513 |       (keyspecs* [_] (keyspecs* impl)))))
 514 | 
 515 | (defmethod s/expand-spec `s/union
 516 |   [[_ & schemas]]
 517 |   {:clojure.spec/op `s/union
 518 |    :schemas (vec schemas)})
 519 | 
 520 | (defmethod s/create-spec `s/union
 521 |   [{:keys [schemas]}]
 522 |   (union-impl schemas nil))
 523 | 
 524 | (defn- select-impl
 525 |   [schema-form selection gfn]
 526 |   (let [id (java.util.UUID/randomUUID)
 527 |         schema (s/schema* schema-form)
 528 |         key-specs (keyspecs schema)
 529 |         req-kset (if (->> selection (filter symbol?) (filter #(= (name %) "*")) seq)
 530 |                    (set (keys key-specs))
 531 |                    (->> selection (filter keyword?) set))
 532 |         sub-selects (->> selection (filter map?) (apply merge))
 533 |         lookup #(if (qualified-keyword? %)
 534 |                   (let [schema-obj (s/get-spec %)]
 535 |                     (if (s/schema? schema-obj)
 536 |                       (let [sub-schema (vec (some-> schema-obj keyspecs keys))
 537 |                             sub-selection (get sub-selects % [])]
 538 |                         (s/resolve-spec `(s/select ~sub-schema ~sub-selection)))
 539 |                       schema-obj))
 540 |                   (get key-specs %))
 541 |         opt-kset (set/difference (set/union (-> key-specs keys set)
 542 |                                             (-> sub-selects keys set))
 543 |                                  req-kset)]
 544 |     (reify
 545 |       Select
 546 |       Spec
 547 |       (conform* [_ x settings-key settings]
 548 |         (if (or (not (map? x))
 549 |                 (not (set/subset? req-kset (-> x keys set))))
 550 |           ::s/invalid
 551 |           (loop [ret x ;; either conformed map or ::s/invalid
 552 |                  [[k v] & ks :as m] x]
 553 |             (if k
 554 |               (let [conformed (if-let [sp (lookup k)]
 555 |                                 (conform* sp v k settings)
 556 |                                 v)]
 557 |                 (if (s/invalid? conformed)
 558 |                   (recur ::s/invalid nil)
 559 |                   (if-let [sub-spec (lookup k)]
 560 |                     (if (not (s/valid? sub-spec (get x k)))
 561 |                       (recur ::s/invalid nil)
 562 |                       (recur (if-not (identical? v conformed) (assoc ret k conformed) ret) ks))
 563 |                     (recur (if-not (identical? v conformed) (assoc ret k conformed) ret) ks))))
 564 |               ret))))
 565 |       (unform* [_ x]
 566 |         (loop [ret x, [[k v] & ks :as m] x]
 567 |           (if-not m
 568 |             ret
 569 |             (if-let [sp (lookup k)]
 570 |               (let [uv (s/unform sp v)]
 571 |                 (recur (if (identical? uv v) ret (assoc ret k uv)) ks))
 572 |               (recur ret ks)))))
 573 |       (explain* [_ path via in x settings-key settings]
 574 |         (if (not (map? x))
 575 |           [{:path path :pred `map? :val x :via via :in in}]
 576 |           (-> (concat
 577 |                 ;; required key missing
 578 |                 (->> req-kset
 579 |                      (keep (fn [k]
 580 |                              (when-not (contains? x k)
 581 |                                {:path path :pred `(fn [~'m] (contains? ~'m ~k)) :val x :via via :in in}))))
 582 |                 ;; registered key has conforming v
 583 |                 (->> x
 584 |                      (keep
 585 |                        (fn [[k v]]
 586 |                          (when-let [sp (lookup k)]
 587 |                            (explain-1 (s/form sp) sp (conj path k) via (conj in k) v k settings))))
 588 |                      (mapcat identity))
 589 |                 ;; nested select matches
 590 |                 (->> sub-selects
 591 |                      (keep
 592 |                        (fn [[k _]]
 593 |                          (when (contains? x k)
 594 |                            (when-let [sp (lookup k)]
 595 |                              (explain-1 (s/form sp) sp (conj path k) via (conj in k) (get x k) k settings)))))
 596 |                      (mapcat identity)))
 597 |               distinct
 598 |               vec)))
 599 |       (gen* [_ overrides path rmap]
 600 |         (if gfn
 601 |           (gfn)
 602 |           (let [rmap (inck rmap id)
 603 |                 rgen (fn [k s] [k (#'s/gensub s overrides (conj path k) rmap k)])
 604 |                 ogen (fn [k s]
 605 |                        (when-not (recur-limit? rmap id path k)
 606 |                          [k (gen/delay (#'s/gensub s overrides (conj path k) rmap k))]))
 607 |                 req-specs (->> req-kset (map lookup) (remove nil?))
 608 |                 reqs (map rgen req-kset req-specs)
 609 |                 opt-specs (->> opt-kset (map lookup) (remove nil?))
 610 |                 opts (remove nil? (map ogen opt-kset opt-specs))]
 611 |             (when (every? identity (concat (map second reqs) (map second opts)))
 612 |               (gen/bind
 613 |                 (gen/tuple (and-k-gen req-kset) (or-k-gen opt-kset))
 614 |                 (fn [[req-ks opt-ks]]
 615 |                   (let [qks (flatten (concat req-ks opt-ks))]
 616 |                     (->> (into reqs opts)
 617 |                          (filter #((set qks) (first %)))
 618 |                          (apply concat)
 619 |                          (apply gen/hash-map)))))))))
 620 |       (with-gen* [_ gfn] (select-impl schema-form selection gfn))
 621 |       (describe* [_] `(s/select ~schema-form ~selection)))))
 622 | 
 623 | (defmethod s/expand-spec `s/select
 624 |   [[_ schema selection]]
 625 |   {:clojure.spec/op `s/select
 626 |    :schema schema
 627 |    :selection selection})
 628 | 
 629 | (defmethod s/create-spec `s/select
 630 |   [{:keys [schema selection] :as x}]
 631 |   (assert (vector? selection))
 632 |   (select-impl schema selection nil))
 633 | 
 634 | (defn- nest-impl
 635 |   [re-form gfn]
 636 |   (let [spec (delay (s/resolve-spec re-form))]
 637 |     (reify
 638 |       Spec
 639 |       (conform* [_ x settings-key settings] (conform* @spec x settings-key settings))
 640 |       (unform* [_ x] (unform* @spec x))
 641 |       (explain* [_ path via in x settings-key settings] (explain* @spec path via in x settings-key settings))
 642 |       (gen* [_ overrides path rmap]
 643 |         (if gfn
 644 |           (gfn)
 645 |           (gen* @spec overrides path rmap)))
 646 |       (with-gen* [_ gfn] (nest-impl re-form gfn))
 647 |       (describe* [_] `(s/nest ~(resolve-form re-form))))))
 648 | 
 649 | (defmethod s/expand-spec `s/nest
 650 |   [[_ re]]
 651 |   {:clojure.spec/op `s/nest
 652 |    :spec re})
 653 | 
 654 | (defmethod s/create-spec `s/nest
 655 |   [{:keys [spec]}]
 656 |   (nest-impl spec nil))
 657 | 
 658 | (defn- multi-spec-impl
 659 |   "Do not call this directly, use 'multi-spec'"
 660 |   ([form mmvar retag] (multi-spec-impl form mmvar retag nil))
 661 |   ([form mmvar retag gfn]
 662 |    (let [id (java.util.UUID/randomUUID)
 663 |          predx #(let [^clojure.lang.MultiFn mm @mmvar]
 664 |                   (and (.getMethod mm ((.dispatchFn mm) %))
 665 |                          (mm %)))
 666 |          dval #((.dispatchFn ^clojure.lang.MultiFn @mmvar) %)
 667 |          tag (if (keyword? retag)
 668 |                #(assoc %1 retag %2)
 669 |                retag)]
 670 |      (reify
 671 |        Spec
 672 |        (conform* [_ x settings-key settings]
 673 |          (if-let [pred (predx x)]
 674 |            (dt pred x form)
 675 |            ::s/invalid))
 676 |        (unform* [_ x] (if-let [pred (predx x)]
 677 |                         (s/unform pred x)
 678 |                         (throw (IllegalStateException. (str "No method of: " form " for dispatch value: " (dval x))))))
 679 |        (explain* [_ path via in x settings-key settings]
 680 |          (let [dv (dval x)
 681 |                path (conj path dv)]
 682 |            (if-let [pred (predx x)]
 683 |              (explain-1 form pred path via in x settings-key settings)
 684 |              [{:path path :pred form :val x :reason "no method" :via via :in in}])))
 685 |        (gen* [_ overrides path rmap]
 686 |          (if gfn
 687 |            (gfn)
 688 |            (let [gen (fn [[k f]]
 689 |                        (let [p (f nil)]
 690 |                          (let [rmap (inck rmap id)]
 691 |                            (when-not (recur-limit? rmap id path k)
 692 |                              (gen/delay
 693 |                                (gen/fmap
 694 |                                  #(tag % k)
 695 |                                  (#'s/gensub p overrides (conj path k) rmap (list 'method form k))))))))
 696 |                  gs (->> (methods @mmvar)
 697 |                          (remove (fn [[k]] (s/invalid? k)))
 698 |                          (map gen)
 699 |                          (remove nil?))]
 700 |              (when (every? identity gs)
 701 |                (gen/one-of gs)))))
 702 |        (with-gen* [_ gfn] (multi-spec-impl form mmvar retag gfn))
 703 |        (describe* [_] `(s/multi-spec ~(resolve-form form) ~retag))))))
 704 | 
 705 | (defmethod s/expand-spec `s/multi-spec
 706 |   [[_ mm retag]]
 707 |   {:clojure.spec/op `s/multi-spec
 708 |    :mm mm
 709 |    :retag retag})
 710 | 
 711 | (defmethod s/create-spec `s/multi-spec
 712 |   [{:keys [mm retag]}]
 713 |   (multi-spec-impl mm (find-var mm) retag))
 714 | 
 715 | (defn- tuple-impl
 716 |   "Do not call this directly, use 'tuple'"
 717 |   ([forms] (tuple-impl forms nil))
 718 |   ([forms gfn]
 719 |    (let [specs (delay (mapv s/resolve-spec forms))
 720 |          cnt (count forms)]
 721 |      (reify
 722 |        Spec
 723 |        (conform* [_ x settings-key settings]
 724 |          (let [specs @specs]
 725 |            (if-not (and (vector? x)
 726 |                           (= (count x) cnt))
 727 |              ::s/invalid
 728 |              (loop [ret x, i 0]
 729 |                (if (= i cnt)
 730 |                  ret
 731 |                  (let [v (x i)
 732 |                        cv (conform* (specs i) v settings-key settings)]
 733 |                    (if (s/invalid? cv)
 734 |                      ::s/invalid
 735 |                      (recur (if (identical? cv v) ret (assoc ret i cv))
 736 |                             (inc i)))))))))
 737 |        (unform* [_ x]
 738 |          (assert (and (vector? x)
 739 |                           (= (count x) (count forms))))
 740 |          (loop [ret x, i 0]
 741 |            (if (= i (count x))
 742 |              ret
 743 |              (let [cv (x i)
 744 |                    v (s/unform (@specs i) cv)]
 745 |                (recur (if (identical? cv v) ret (assoc ret i v))
 746 |                       (inc i))))))
 747 |        (explain* [_ path via in x settings-key settings]
 748 |          (cond
 749 |            (not (vector? x))
 750 |            [{:path path :pred `vector? :val x :via via :in in}]
 751 | 
 752 |            (not= (count x) (count forms))
 753 |            [{:path path :pred `(= (count ~'%) ~(count forms)) :val x :via via :in in}]
 754 | 
 755 |            :else
 756 |            (apply concat
 757 |                   (map (fn [i form pred]
 758 |                          (let [v (x i)]
 759 |                            (when-not (pvalid? pred v)
 760 |                              (explain-1 form pred (conj path i) via (conj in i) v settings-key settings))))
 761 |                        (range (count forms)) forms @specs))))
 762 |        (gen* [_ overrides path rmap]
 763 |          (if gfn
 764 |            (gfn)
 765 |            (let [gen (fn [i p f]
 766 |                        (#'s/gensub p overrides (conj path i) rmap f))
 767 |                  gs (map gen (range (count forms)) @specs forms)]
 768 |              (when (every? identity gs)
 769 |                (apply gen/tuple gs)))))
 770 |        (with-gen* [_ gfn] (tuple-impl forms gfn))
 771 |        (describe* [_] `(s/tuple ~@(resolve-forms forms)))))))
 772 | 
 773 | (defmethod s/expand-spec `s/tuple
 774 |   [[_ & preds]]
 775 |   {:clojure.spec/op `s/tuple
 776 |    :specs (vec preds)})
 777 | 
 778 | (defmethod s/create-spec `s/tuple
 779 |   [{:keys [specs]}]
 780 |   (tuple-impl (vec specs)))
 781 | 
 782 | (defn- tagged-ret [tag ret]
 783 |   (clojure.lang.MapEntry. tag ret))
 784 | 
 785 | (defn- or-spec-impl
 786 |   "Do not call this directly, use 'or'"
 787 |   [keys forms gfn]
 788 |   (let [id (java.util.UUID/randomUUID)
 789 |         specs (delay (mapv s/resolve-spec forms))
 790 |         kps (zipmap keys @specs)
 791 |         cform (case (count forms)
 792 |                 2 (fn [x settings-key settings]
 793 |                     (let [specs @specs
 794 |                           ret (conform* (specs 0) x settings-key settings)]
 795 |                       (if (s/invalid? ret)
 796 |                         (let [ret (conform* (specs 1) x settings-key settings)]
 797 |                           (if (s/invalid? ret)
 798 |                             ::s/invalid
 799 |                             (tagged-ret (keys 1) ret)))
 800 |                         (tagged-ret (keys 0) ret))))
 801 |                 3 (fn [x settings-key settings]
 802 |                     (let [specs @specs
 803 |                           ret (conform* (specs 0) x settings-key settings)]
 804 |                       (if (s/invalid? ret)
 805 |                         (let [ret (conform* (specs 1) x settings-key settings)]
 806 |                           (if (s/invalid? ret)
 807 |                             (let [ret (conform* (specs 2) x settings-key settings)]
 808 |                               (if (s/invalid? ret)
 809 |                                 ::s/invalid
 810 |                                 (tagged-ret (keys 2) ret)))
 811 |                             (tagged-ret (keys 1) ret)))
 812 |                         (tagged-ret (keys 0) ret))))
 813 |                 (fn [x settings-key settings]
 814 |                   (let [specs @specs]
 815 |                     (loop [i 0]
 816 |                       (if (< i (count specs))
 817 |                         (let [spec (specs i)]
 818 |                           (let [ret (conform* spec x settings-key settings)]
 819 |                             (if (s/invalid? ret)
 820 |                               (recur (inc i))
 821 |                               (tagged-ret (keys i) ret))))
 822 |                         ::s/invalid)))))]
 823 |     (reify
 824 |       Spec
 825 |       (conform* [_ x settings-key settings] (cform x settings-key settings))
 826 |       (unform* [_ [k x]] (s/unform (kps k) x))
 827 |       (explain* [this path via in x settings-key settings]
 828 |         (when-not (pvalid? this x)
 829 |           (apply concat
 830 |                  (map (fn [k form pred]
 831 |                         (when-not (pvalid? pred x)
 832 |                           (explain-1 form pred (conj path k) via in x settings-key settings)))
 833 |                       keys forms @specs))))
 834 |       (gen* [_ overrides path rmap]
 835 |         (if gfn
 836 |           (gfn)
 837 |           (let [gen (fn [k p f]
 838 |                       (let [rmap (inck rmap id)]
 839 |                         (when-not (recur-limit? rmap id path k)
 840 |                           (gen/delay
 841 |                             (#'s/gensub p overrides (conj path k) rmap f)))))
 842 |                 gs (remove nil? (map gen keys @specs forms))]
 843 |             (when-not (empty? gs)
 844 |               (gen/one-of gs)))))
 845 |       (with-gen* [_ gfn] (or-spec-impl keys forms gfn))
 846 |       (describe* [_] `(s/or ~@(mapcat vector keys (map resolve-form forms)))))))
 847 | 
 848 | (defmethod s/create-spec `s/or
 849 |   [{:keys [keys specs]}]
 850 |   (assert (= (count keys) (count specs)))
 851 |   (or-spec-impl keys specs nil))
 852 | 
 853 | (defmethod s/expand-spec `s/or
 854 |   [[_ & key-pred-forms]]
 855 |   (let [pairs (partition 2 key-pred-forms)
 856 |         keys (mapv first pairs)
 857 |         specs (mapv second pairs)]
 858 |     {:clojure.spec/op `s/or
 859 |      :keys keys
 860 |      :specs specs}))
 861 | 
 862 | (defn- and-spec-impl
 863 |   "Do not call this directly, use 'and'"
 864 |   [forms gfn]
 865 |   (let [specs (delay (mapv s/resolve-spec forms))
 866 |         cform
 867 |         (case (count forms)
 868 |           2 (fn [x settings-key settings]
 869 |               (let [specs @specs
 870 |                     ret (conform* (specs 0) x settings-key settings)]
 871 |                 (if (s/invalid? ret)
 872 |                   ::s/invalid
 873 |                   (conform* (specs 1) ret settings-key settings))))
 874 |           3 (fn [x settings-key settings]
 875 |               (let [specs @specs
 876 |                     ret (conform* (specs 0) x settings-key settings)]
 877 |                 (if (s/invalid? ret)
 878 |                   ::s/invalid
 879 |                   (let [ret (conform* (specs 1) ret settings-key settings)]
 880 |                     (if (s/invalid? ret)
 881 |                       ::s/invalid
 882 |                       (conform* (specs 2) ret settings-key settings))))))
 883 |           (fn [x settings-key settings]
 884 |             (let [specs @specs]
 885 |               (loop [ret x i 0]
 886 |                 (if (< i (count specs))
 887 |                   (let [nret (conform* (specs i) ret settings-key settings)]
 888 |                     (if (s/invalid? nret)
 889 |                       ::s/invalid
 890 |                       ;;propagate conformed values
 891 |                       (recur nret (inc i))))
 892 |                   ret)))))]
 893 |     (reify
 894 |       Spec
 895 |       (conform* [_ x settings-key settings] (cform x settings-key settings))
 896 |       (unform* [_ x] (reduce #(s/unform %2 %1) x (reverse @specs)))
 897 |       (explain* [_ path via in x settings-key settings] (explain-pred-list (map s/form @specs) @specs path via in x settings-key settings))
 898 | 
 899 |       (gen* [_ overrides path rmap] (if gfn (gfn) (#'s/gensub (first @specs) overrides path rmap (first forms))))
 900 |       (with-gen* [_ gfn] (and-spec-impl forms gfn))
 901 |       (describe* [_] `(s/and ~@(resolve-forms forms))))))
 902 | 
 903 | (defmethod s/expand-spec `s/and
 904 |   [[_ & pred-forms]]
 905 |   {:clojure.spec/op `s/and
 906 |    :specs (vec pred-forms)})
 907 | 
 908 | (defmethod s/create-spec `s/and
 909 |   [{:keys [specs]}]
 910 |   (and-spec-impl specs nil))
 911 | 
 912 | (defn- explain-pred-list-nonflowing
 913 |   [forms preds path via in x settings-key settings]
 914 |   (loop [[form & forms] forms
 915 |          [pred & preds] preds]
 916 |     (when pred
 917 |       (let [nret (dt pred x form)]
 918 |         (if (s/invalid? nret)
 919 |           (explain-1 form pred path via in x settings-key settings)
 920 |           (recur forms preds))))))
 921 | 
 922 | (defn- and-nonflowing
 923 |   "Do not call this directly, use 'and-'"
 924 |   [forms gfn]
 925 |   (let [specs (delay (mapv s/resolve-spec forms))]
 926 |     (reify
 927 |       Spec
 928 |       (conform* [_ x settings-key settings]
 929 |         (let [specs @specs]
 930 |           (if (seq specs)
 931 |             (let [ret (conform* (specs 0) x settings-key settings)]
 932 |               (if (s/invalid? ret)
 933 |                 ::s/invalid
 934 |                 (loop [i 1]
 935 |                   (if (< i (count specs))
 936 |                     (if (s/invalid? (conform* (specs i) x settings-key settings))
 937 |                       ::s/invalid
 938 |                       (recur (inc i)))
 939 |                     ret))))
 940 |             x)))
 941 |       (unform* [_ x]
 942 |         (let [specs @specs]
 943 |           (if (seq specs)
 944 |             (s/unform (first specs) x)
 945 |             x)))
 946 |       (explain* [_ path via in x settings-key settings]
 947 |         (let [specs @specs]
 948 |           (explain-pred-list-nonflowing (map s/form specs) specs path via in x settings-key settings)))
 949 |       (gen* [_ overrides path rmap]
 950 |         (if gfn
 951 |           (gfn)
 952 |           (let [specs @specs]
 953 |             (if (seq specs)
 954 |               (#'s/gensub (first specs) overrides path rmap (first forms))
 955 |               (#'s/gensub (s/resolve-spec `any?) overrides path rmap `any?)))))
 956 |       (with-gen* [_ gfn] (and-nonflowing forms gfn))
 957 |       (describe* [_] `(s/and- ~@(resolve-forms forms))))))
 958 | 
 959 | (defmethod s/expand-spec `s/and-
 960 |   [[_ & pred-forms]]
 961 |   {:clojure.spec/op `s/and-
 962 |    :specs (vec pred-forms)})
 963 | 
 964 | (defmethod s/create-spec `s/and-
 965 |   [{:keys [specs]}]
 966 |   (and-nonflowing specs nil))
 967 | 
 968 | (defn- merge-spec-impl
 969 |   "Do not call this directly, use 'merge'"
 970 |   [forms preds gfn]
 971 |   (reify
 972 |     Spec
 973 |     (conform* [_ x settings-key settings]
 974 |       (let [ms (map #(dt %1 x %2) preds forms)]
 975 |         (if (some s/invalid? ms)
 976 |           ::s/invalid
 977 |           (apply merge ms))))
 978 |     (unform* [_ x] (apply merge (map #(s/unform % x) (reverse preds))))
 979 |     (explain* [_ path via in x settings-key settings]
 980 |       (apply concat
 981 |              (map #(explain-1 %1 %2 path via in x settings-key settings)
 982 |                   forms preds)))
 983 |     (gen* [_ overrides path rmap]
 984 |       (if gfn
 985 |         (gfn)
 986 |         (gen/fmap
 987 |           #(apply merge %)
 988 |           (apply gen/tuple (map #(#'s/gensub %1 overrides path rmap %2)
 989 |                                 preds forms)))))
 990 |     (with-gen* [_ gfn] (merge-spec-impl forms preds gfn))
 991 |     (describe* [_] `(s/merge ~@(resolve-forms forms)))))
 992 | 
 993 | (defmethod s/expand-spec `s/merge
 994 |   [[_ & pred-forms]]
 995 |   {:clojure.spec/op `s/merge
 996 |    :specs (vec pred-forms)})
 997 | 
 998 | (defmethod s/create-spec `s/merge
 999 |   [{:keys [specs]}]
1000 |   (merge-spec-impl specs (mapv s/resolve-spec specs) nil))
1001 | 
1002 | (defn- coll-prob [x kfn kform distinct count min-count max-count
1003 |                   path via in settings-key settings]
1004 |   (let [pred (or kfn coll?)
1005 |         kform (or kform `coll?)]
1006 |     (cond
1007 |       (not (pvalid? pred x))
1008 |       (explain-1 kform pred path via in x settings-key settings)
1009 | 
1010 |       (and count (not= count (bounded-count count x)))
1011 |       [{:path path :pred `(= ~count (count ~'%)) :val x :via via :in in}]
1012 | 
1013 |       (and (or min-count max-count)
1014 |              (not (<= (or min-count 0)
1015 |                       (bounded-count (if max-count (inc max-count) min-count) x)
1016 |                       (or max-count Integer/MAX_VALUE))))
1017 |       [{:path path :pred `(<= ~(or min-count 0) (count ~'%) ~(or max-count 'Integer/MAX_VALUE)) :val x :via via :in in}]
1018 | 
1019 |       (and distinct (not (empty? x)) (not (apply distinct? x)))
1020 |       [{:path path :pred 'distinct? :val x :via via :in in}])))
1021 | 
1022 | (def ^:private empty-coll {`vector? [], `set? #{}, `list? (), `map? {}})
1023 | 
1024 | (defn- every-impl
1025 |   "Do not call this directly, use 'every', 'every-kv', 'coll-of' or 'map-of'"
1026 |   ([form opts] (every-impl form opts nil))
1027 |   ([form {conform-into :into
1028 |           describe-form ::s/describe
1029 |           :keys [kind ::s/kind-form count max-count min-count distinct gen-max ::s/kfn ::s/cpred
1030 |                  conform-keys ::s/conform-all]
1031 |           :or {gen-max 20}
1032 |           :as opts}
1033 |     gfn]
1034 |    (let [gen-into (if conform-into (empty conform-into) (get empty-coll kind-form))
1035 |          spec (delay (s/resolve-spec form))
1036 |          check? #(s/valid? @spec %)
1037 |          kfn (if kfn (s/resolve-fn kfn) (fn [i v] v))
1038 |          addcv (fn [ret i v cv] (conj ret cv))
1039 |          cfns (fn [x]
1040 |                 ;;returns a tuple of [init add complete] fns
1041 |                 (cond
1042 |                   (and (vector? x) (or (not conform-into) (vector? conform-into)))
1043 |                   [identity
1044 |                    (fn [ret i v cv]
1045 |                      (if (identical? v cv)
1046 |                        ret
1047 |                        (assoc ret i cv)))
1048 |                    identity]
1049 | 
1050 |                   (and (map? x) (or (and kind (not conform-into)) (map? conform-into)))
1051 |                   [(if conform-keys empty identity)
1052 |                    (fn [ret i v cv]
1053 |                      (if (and (identical? v cv) (not conform-keys))
1054 |                        ret
1055 |                        (assoc ret (nth (if conform-keys cv v) 0) (nth cv 1))))
1056 |                    identity]
1057 | 
1058 |                   (or (list? conform-into) (seq? conform-into) (and (not conform-into) (or (list? x) (seq? x))))
1059 |                   [(constantly ()) addcv reverse]
1060 | 
1061 |                   :else [#(empty (or conform-into %)) addcv identity]))]
1062 |      (reify
1063 |        Spec
1064 |        (conform* [_ x settings-key settings]
1065 |          (let [spec @spec]
1066 |            (cond
1067 |              (not (cpred x)) ::s/invalid
1068 |              conform-all
1069 |              (let [[init add complete] (cfns x)]
1070 |                (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)]
1071 |                  (if vseq
1072 |                    (let [cv (conform* spec v settings-key settings)]
1073 |                      (if (s/invalid? cv)
1074 |                        ::s/invalid
1075 |                        (recur (add ret i v cv) (inc i) vs)))
1076 |                    (complete ret))))
1077 |              :else
1078 |              (if (indexed? x)
1079 |                (let [step (max 1 (long (/ (clojure.core/count x) s/*coll-check-limit*)))]
1080 |                  (loop [i 0]
1081 |                    (if (>= i (clojure.core/count x))
1082 |                      x
1083 |                      (if (s/valid? spec (nth x i))
1084 |                        (recur (+ i step))
1085 |                        ::s/invalid))))
1086 |                (let [limit s/*coll-check-limit*]
1087 |                  (loop [i 0 [v & vs :as vseq] (seq x)]
1088 |                    (cond
1089 |                      (or (nil? vseq) (= i limit)) x
1090 |                      (s/valid? spec v) (recur (inc i) vs)
1091 |                      :else ::s/invalid)))))))
1092 |        (unform* [_ x]
1093 |          (if conform-all
1094 |            (let [spec @spec
1095 |                  [init add complete] (cfns x)]
1096 |              (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)]
1097 |                (if (>= i (clojure.core/count x))
1098 |                  (complete ret)
1099 |                  (recur (add ret i v (s/unform spec v)) (inc i) vs))))
1100 |            x))
1101 |        (explain* [_ path via in x settings-key settings]
1102 |          (or (coll-prob x kind kind-form distinct count min-count max-count
1103 |                           path via in settings-key settings)
1104 |                (apply concat
1105 |                       ((if conform-all identity (partial take s/*coll-error-limit*))
1106 |                         (keep identity
1107 |                               (map (fn [i v]
1108 |                                      (let [k (kfn i v)]
1109 |                                        (when-not (check? v)
1110 |                                          (let [prob (explain-1 form @spec path via (conj in k) v settings-key settings)]
1111 |                                            prob))))
1112 |                                    (range) x))))))
1113 |        (gen* [_ overrides path rmap]
1114 |          (if gfn
1115 |            (gfn)
1116 |            (let [pgen (#'s/gensub @spec overrides path rmap form)]
1117 |              (gen/bind
1118 |                (cond
1119 |                  gen-into (gen/return gen-into)
1120 |                  kind (gen/fmap #(if (empty? %) % (empty %))
1121 |                                 (#'s/gensub (s/resolve-spec kind-form) overrides path rmap form))
1122 |                  :else (gen/return []))
1123 |                (fn [init]
1124 |                  (gen/fmap
1125 |                    #(if (vector? init) % (into init %))
1126 |                    (cond
1127 |                      distinct
1128 |                      (if count
1129 |                        (gen/vector-distinct pgen {:num-elements count :max-tries 100})
1130 |                        (gen/vector-distinct pgen {:min-elements (or min-count 0)
1131 |                                                   :max-elements (or max-count (max gen-max (* 2 (or min-count 0))))
1132 |                                                   :max-tries 100}))
1133 | 
1134 |                      count
1135 |                      (gen/vector pgen count)
1136 | 
1137 |                      (or min-count max-count)
1138 |                      (gen/vector pgen (or min-count 0) (or max-count (max gen-max (* 2 (or min-count 0)))))
1139 | 
1140 |                      :else
1141 |                      (gen/vector pgen 0 gen-max))))))))
1142 | 
1143 |        (with-gen* [_ gfn] (every-impl form opts gfn))
1144 |        (describe* [_] describe-form)))))
1145 | 
1146 | (defmethod s/expand-spec `s/every
1147 |   [[_ pred & opts]]
1148 |   {:clojure.spec/op `s/every
1149 |    :spec pred
1150 |    :opts (apply hash-map opts)})
1151 | 
1152 | (defmethod s/create-spec `s/every
1153 |   [{:keys [spec opts]}]
1154 |   (let [{:keys [into kind count max-count min-count distinct gen-max gen]} opts
1155 |         gx (gensym)
1156 |         cpreds (cond-> [(list (or kind `coll?) gx)]
1157 |                        count (conj `(= ~count (bounded-count ~count ~gx)))
1158 |                        (or min-count max-count)
1159 |                        (conj `(<= (or ~min-count 0)
1160 |                                   (bounded-count (if ~max-count (inc ~max-count) ~min-count) ~gx)
1161 |                                   (or ~max-count Integer/MAX_VALUE)))
1162 | 
1163 |                        distinct
1164 |                        (conj `(or (empty? ~gx) (apply distinct? ~gx))))
1165 |         cpred `(fn* [~gx] (and ~@cpreds))
1166 |         eopts (-> opts
1167 |                   (dissoc ::s/gen)
1168 |                   (assoc ::s/cpred (s/resolve-fn cpred))
1169 |                   (cond->
1170 |                     kind (assoc :kind (s/resolve-fn kind) ::s/kind-form kind)))]
1171 |     (every-impl spec eopts gen)))
1172 | 
1173 | (defmethod s/expand-spec `s/every-kv
1174 |   [[_ kpred vpred & opts]]
1175 |   {:clojure.spec/op `s/every-kv
1176 |    :kspec kpred
1177 |    :vspec vpred
1178 |    :opts (apply hash-map opts)})
1179 | 
1180 | (defmethod s/create-spec `s/every-kv
1181 |   [{:keys [kspec vspec opts]}]
1182 |   (s/create-spec
1183 |     {:clojure.spec/op `s/every
1184 |      :spec `(s/tuple ~kspec ~vspec)
1185 |      :opts (merge opts {::s/kfn (fn [i# v#] (nth v# 0))
1186 |                         :into {}
1187 |                         ::s/describe `(s/every-kv ~(resolve-form kspec) ~(resolve-form vspec) ~@(mapcat identity opts))})}))
1188 | 
1189 | (defmethod s/expand-spec `s/coll-of
1190 |   [[_ pred & opts]]
1191 |   {:clojure.spec/op `s/coll-of
1192 |    :spec pred
1193 |    :opts (apply hash-map opts)})
1194 | 
1195 | (defmethod s/create-spec `s/coll-of
1196 |   [{:keys [spec opts]}]
1197 |   (s/create-spec
1198 |     {:clojure.spec/op `s/every
1199 |      :spec spec
1200 |      :opts (merge opts {::s/conform-all true
1201 |                         ::s/describe `(s/coll-of ~(resolve-form spec) ~@(mapcat identity opts))})}))
1202 | 
1203 | (defmethod s/expand-spec `s/map-of
1204 |   [[_ kpred vpred & opts]]
1205 |   {:clojure.spec/op `s/map-of
1206 |    :kspec kpred
1207 |    :vspec vpred
1208 |    :opts (apply hash-map opts)})
1209 | 
1210 | (defmethod s/create-spec `s/map-of
1211 |   [{:keys [kspec vspec opts]}]
1212 |   (s/create-spec
1213 |     {:clojure.spec/op `s/every
1214 |      :spec `(s/tuple ~kspec ~vspec)
1215 |      :opts (merge opts {::s/kfn (fn [i# v#] (nth v# 0))
1216 |                         :into {}
1217 |                         ::s/conform-all true
1218 |                         :kind `map?
1219 |                         ::s/describe `(s/map-of ~(resolve-form kspec) ~(resolve-form vspec) ~@(mapcat identity opts))})}))
1220 | 
1221 | ;;;;;;;;;;;;;;;;;;;;;;; regex ;;;;;;;;;;;;;;;;;;;
1222 | ;;See:
1223 | ;; http://matt.might.net/articles/implementation-of-regular-expression-matching-in-scheme-with-derivatives/
1224 | ;; http://www.ccs.neu.edu/home/turon/re-deriv.pdf
1225 | 
1226 | (declare re-conform re-explain re-gen op-unform op-describe)
1227 | 
1228 | ;;ctors
1229 | 
1230 | (defn- as-regex-spec
1231 |   ([re-obj]
1232 |     (as-regex-spec re-obj nil))
1233 |   ([re-obj gfn]
1234 |    (with-meta
1235 |      re-obj
1236 |      {`protocols/conform* (fn [re x settings-key settings]
1237 |                             (if (or (nil? x) (sequential? x))
1238 |                               (let [ret (re-conform re (seq x))]
1239 |                                 (if (and (vector? x) (map? ret))
1240 |                                   (with-meta ret {::s/into []})
1241 |                                   ret))
1242 |                               ::s/invalid))
1243 |       `protocols/unform* (fn [re x]
1244 |                            (let [ret (op-unform re x)]
1245 |                              (if (= (-> x meta ::s/into) [])
1246 |                                (vec ret)
1247 |                                ret)))
1248 |       `protocols/explain* (fn [re path via in x settings-key settings]
1249 |                             (if (or (nil? x) (sequential? x))
1250 |                               (re-explain path via in re (seq x) settings-key settings)
1251 |                               [{:path path :pred (#'s/res `#(or (nil? %) (sequential? %))) :val x :via via :in in}]))
1252 |       `protocols/gen* (fn [re overrides path rmap]
1253 |                         (if gfn
1254 |                           (gfn)
1255 |                           (re-gen re overrides path rmap (op-describe re))))
1256 |       `protocols/with-gen* (fn [re gfn]
1257 |                              (as-regex-spec re gfn))
1258 |       `protocols/describe* (fn [re]
1259 |                              (op-describe re))})))
1260 | 
1261 | (defn- accept [x] (as-regex-spec {::s/op ::s/accept :ret x}))
1262 | 
1263 | (defn- accept? [{:keys [::s/op]}]
1264 |   (= ::s/accept op))
1265 | 
1266 | (defn- pcat* [{[p1 & pr :as ps] :ps,  [k1 & kr :as ks] :ks, [f1 & fr :as forms] :forms, ret :ret, rep+ :rep+}]
1267 |   (when (every? identity ps)
1268 |     (if (accept? p1)
1269 |       (let [rp (:ret p1)
1270 |             ret (conj ret (if ks {k1 rp} rp))]
1271 |         (if pr
1272 |           (pcat* {:ps pr :ks kr :forms fr :ret ret})
1273 |           (accept ret)))
1274 |       (as-regex-spec {::s/op ::s/pcat, :ps ps, :ret ret, :ks ks, :forms forms :rep+ rep+}))))
1275 | 
1276 | (defn- pcat [& ps] (pcat* {:ps ps :ret []}))
1277 | 
1278 | (defn- cat-impl
1279 |   "Do not call this directly, use 'cat'"
1280 |   [ks ps forms]
1281 |   (pcat* {:ks ks, :ps ps, :forms forms, :ret {}}))
1282 | 
1283 | (defn- rep* [p1 p2 ret splice form]
1284 |   (when p1
1285 |     (let [r (as-regex-spec {::s/op ::s/rep, :p2 p2, :splice splice, :forms form :id (java.util.UUID/randomUUID)})]
1286 |       (if (accept? p1)
1287 |         (assoc r :p1 p2 :ret (conj ret (:ret p1)))
1288 |         (assoc r :p1 p1, :ret ret)))))
1289 | 
1290 | (defn- rep-impl
1291 |   "Do not call this directly, use '*'"
1292 |   [form p]
1293 |   (rep* p p [] false form))
1294 | 
1295 | (defn- rep+impl
1296 |   "Do not call this directly, use '+'"
1297 |   [form p]
1298 |   (pcat* {:ps [p (rep* p p [] true form)] :forms `[~form (s/* ~form)] :ret [] :rep+ form}))
1299 | 
1300 | (defn- amp-impl
1301 |   "Do not call this directly, use '&'"
1302 |   [re re-form preds pred-forms]
1303 |   (as-regex-spec {::s/op ::s/amp :p1 re :amp re-form :ps preds :forms pred-forms}))
1304 | 
1305 | (defn- filter-alt [ps ks forms f]
1306 |   (if (or ks forms)
1307 |     (let [pks (->> (map vector ps
1308 |                         (or (seq ks) (repeat nil))
1309 |                         (or (seq forms) (repeat nil)))
1310 |                    (filter #(-> % first f)))]
1311 |       [(seq (map first pks)) (when ks (seq (map second pks))) (when forms (seq (map #(nth % 2) pks)))])
1312 |     [(seq (filter f ps)) ks forms]))
1313 | 
1314 | (defn- alt* [ps ks forms]
1315 |   (let [[[p1 & pr :as ps] [k1 :as ks] forms] (filter-alt ps ks forms identity)]
1316 |     (when ps
1317 |       (let [ret (as-regex-spec {::s/op ::s/alt, :ps ps, :ks ks :forms forms})]
1318 |         (if (nil? pr)
1319 |           (if k1
1320 |             (if (accept? p1)
1321 |               (accept (tagged-ret k1 (:ret p1)))
1322 |               ret)
1323 |             p1)
1324 |           ret)))))
1325 | 
1326 | (defn- alts [& ps] (alt* ps nil nil))
1327 | (defn- alt2 [p1 p2] (if (and p1 p2) (alts p1 p2) (or p1 p2)))
1328 | 
1329 | (defn- alt-impl
1330 |   "Do not call this directly, use 'alt'"
1331 |   [ks ps forms] (assoc (alt* ps ks forms) :id (java.util.UUID/randomUUID)))
1332 | 
1333 | (defn- maybe-impl
1334 |   "Do not call this directly, use '?'"
1335 |   [p form] (assoc (alt* [p (accept ::s/nil)] nil [form ::s/nil]) :maybe form))
1336 | 
1337 | (defn- noret? [p1 pret]
1338 |   (or (= pret ::s/nil)
1339 |         (and (#{::s/rep ::s/pcat} (::s/op (#'s/reg-resolve! p1))) ;;hrm, shouldn't know these
1340 |                (empty? pret))
1341 |         nil))
1342 | 
1343 | (declare preturn)
1344 | 
1345 | (defn- and-preds [x preds forms]
1346 |   (loop [ret x
1347 |          [pred & preds] preds
1348 |          [form & forms] forms]
1349 |     (if pred
1350 |       (let [nret (dt pred ret form)]
1351 |         (if (s/invalid? nret)
1352 |           ::s/invalid
1353 |           ;;propagate conformed values
1354 |           (recur nret preds forms)))
1355 |       ret)))
1356 | 
1357 | (defn- accept-nil? [p]
1358 |   (let [{:keys [::s/op ps p1 p2 forms] :as p} (#'s/reg-resolve! p)]
1359 |     (case op
1360 |       ::s/accept true
1361 |       nil nil
1362 |       ::s/amp (and (accept-nil? p1)
1363 |                    (let [ret (-> (preturn p1) (and-preds ps (next forms)))]
1364 |                      (not (s/invalid? ret))))
1365 |       ::s/rep (or (identical? p1 p2) (accept-nil? p1))
1366 |       ::s/pcat (every? accept-nil? ps)
1367 |       ::s/alt (some accept-nil? ps))))
1368 | 
1369 | (declare add-ret)
1370 | 
1371 | (defn- preturn [p]
1372 |   (let [{[p0 & pr :as ps] :ps, [k :as ks] :ks, :keys [::s/op p1 ret forms] :as p} (#'s/reg-resolve! p)]
1373 |     (case op
1374 |       ::s/accept ret
1375 |       nil nil
1376 |       ::s/amp (let [pret (preturn p1)]
1377 |               (if (noret? p1 pret)
1378 |                 ::s/nil
1379 |                 (and-preds pret ps forms)))
1380 |       ::s/rep (add-ret p1 ret k)
1381 |       ::s/pcat (add-ret p0 ret k)
1382 |       ::s/alt (let [[[p0] [k0]] (filter-alt ps ks forms accept-nil?)
1383 |                   r (if (nil? p0) ::s/nil (preturn p0))]
1384 |               (if k0 (tagged-ret k0 r) r)))))
1385 | 
1386 | (defn- op-unform [p x]
1387 |   ;;(prn {:p p :x x})
1388 |   (let [{[p0 & pr :as ps] :ps, [k :as ks] :ks, :keys [::s/op p1 ret forms rep+ maybe] :as p} (#'s/reg-resolve! p)
1389 |         kps (zipmap ks ps)]
1390 |     (case op
1391 |       ::s/accept [ret]
1392 |       nil [(s/unform p x)]
1393 |       ::s/amp (let [px (reduce #(s/unform %2 %1) x (reverse ps))]
1394 |               (op-unform p1 px))
1395 |       ::s/rep (mapcat #(op-unform p1 %) x)
1396 |       ::s/pcat (if rep+
1397 |                (mapcat #(op-unform p0 %) x)
1398 |                (mapcat (fn [k]
1399 |                          (when (contains? x k)
1400 |                            (op-unform (kps k) (get x k))))
1401 |                        ks))
1402 |       ::s/alt (if maybe
1403 |               [(s/unform p0 x)]
1404 |               (let [[k v] x]
1405 |                 (op-unform (kps k) v))))))
1406 | 
1407 | (defn- add-ret [p r k]
1408 |   (let [{:keys [::s/op ps splice] :as p} (#'s/reg-resolve! p)
1409 |         prop #(let [ret (preturn p)]
1410 |                 (if (empty? ret) r ((if splice into conj) r (if k {k ret} ret))))]
1411 |     (case op
1412 |       nil r
1413 |       (::s/alt ::s/accept ::s/amp)
1414 |       (let [ret (preturn p)]
1415 |         ;;(prn {:ret ret})
1416 |         (if (= ret ::s/nil) r (conj r (if k {k ret} ret))))
1417 | 
1418 |       (::s/rep ::s/pcat) (prop))))
1419 | 
1420 | (defn- deriv
1421 |   [p x]
1422 |   (let [{[p0 & pr :as ps] :ps, [k0 & kr :as ks] :ks, :keys [::s/op p1 p2 ret splice forms amp] :as p} (#'s/reg-resolve! p)]
1423 |     (when p
1424 |       (case op
1425 |         ::s/accept nil
1426 |         nil (let [ret (dt p x p)]
1427 |               (when-not (s/invalid? ret) (accept ret)))
1428 |         ::s/amp (when-let [p1 (deriv p1 x)]
1429 |                 (if (= ::s/accept (::s/op p1))
1430 |                   (let [ret (-> (preturn p1) (and-preds ps (next forms)))]
1431 |                     (when-not (s/invalid? ret)
1432 |                       (accept ret)))
1433 |                   (amp-impl p1 amp ps forms)))
1434 |         ::s/pcat (alt2 (pcat* {:ps (cons (deriv p0 x) pr), :ks ks, :forms forms, :ret ret})
1435 |                      (when (accept-nil? p0) (deriv (pcat* {:ps pr, :ks kr, :forms (next forms), :ret (add-ret p0 ret k0)}) x)))
1436 |         ::s/alt (alt* (map #(deriv % x) ps) ks forms)
1437 |         ::s/rep (alt2 (rep* (deriv p1 x) p2 ret splice forms)
1438 |                     (when (accept-nil? p1) (deriv (rep* p2 p2 (add-ret p1 ret nil) splice forms) x)))))))
1439 | 
1440 | (defn- op-describe [p]
1441 |   (let [{:keys [::s/op ps ks forms splice p1 rep+ maybe amp] :as p} (#'s/reg-resolve! p)]
1442 |     ;;(prn {:op op :ks ks :forms forms :p p})
1443 |     (when p
1444 |       (case op
1445 |         ::s/accept nil
1446 |         nil p
1447 |         ::s/amp (list* 'clojure.alpha.spec/& (resolve-form amp) (resolve-forms forms))
1448 |         ::s/pcat (if rep+
1449 |                  (list `s/+ rep+)
1450 |                  (cons `s/cat (mapcat vector (or (seq ks) (repeat :_)) (resolve-forms forms))))
1451 |         ::s/alt (if maybe
1452 |                 (list `s/? maybe)
1453 |                 (cons `s/alt (mapcat vector ks (resolve-forms forms))))
1454 |         ::s/rep (list (if splice `s/+ `s/*) (resolve-form forms))))))
1455 | 
1456 | (defn- op-explain [form p path via in input settings-key settings]
1457 |   ;;(prn {:form form :p p :path path :input input})
1458 |   (let [[x :as input] input
1459 |         {:keys [::s/op ps ks forms splice p1 p2] :as p} (#'s/reg-resolve! p)
1460 |         via (if-let [name (#'s/spec-name p)] (conj via name) via)
1461 |         insufficient (fn [path form]
1462 |                        [{:path path
1463 |                          :reason "Insufficient input"
1464 |                          :pred form
1465 |                          :val ()
1466 |                          :via via
1467 |                          :in in}])]
1468 |     (when p
1469 |       (case op
1470 |         ::s/accept nil
1471 |         nil (if (empty? input)
1472 |               (insufficient path form)
1473 |               (explain-1 form p path via in x settings-key settings))
1474 |         ::s/amp (if (empty? input)
1475 |                 (if (accept-nil? p1)
1476 |                   (explain-pred-list forms ps path via in (preturn p1) settings-key settings)
1477 |                   (insufficient path (:amp p)))
1478 |                 (if-let [p1 (deriv p1 x)]
1479 |                   (explain-pred-list forms ps path via in (preturn p1) settings-key settings)
1480 |                   (op-explain (:amp p) p1 path via in input settings-key settings)))
1481 |         ::s/pcat (let [pkfs (map vector
1482 |                                ps
1483 |                                (or (seq ks) (repeat nil))
1484 |                                (or (seq forms) (repeat nil)))
1485 |                      [pred k form] (if (= 1 (count pkfs))
1486 |                                      (first pkfs)
1487 |                                      (first (remove (fn [[p]] (accept-nil? p)) pkfs)))
1488 |                      path (if k (conj path k) path)
1489 |                      form (or form (op-describe pred))]
1490 |                  (if (and (empty? input) (not pred))
1491 |                    (insufficient path form)
1492 |                    (op-explain form pred path via in input settings-key settings)))
1493 |         ::s/alt (if (empty? input)
1494 |                 (insufficient path (op-describe p))
1495 |                 (apply concat
1496 |                        (map (fn [k form pred]
1497 |                               (op-explain (or form (op-describe pred))
1498 |                                           pred
1499 |                                           (if k (conj path k) path)
1500 |                                           via
1501 |                                           in
1502 |                                           input
1503 |                                           settings-key
1504 |                                           settings))
1505 |                             (or (seq ks) (repeat nil))
1506 |                             (or (seq forms) (repeat nil))
1507 |                             ps)))
1508 |         ::s/rep (op-explain (if (identical? p1 p2)
1509 |                             forms
1510 |                             (op-describe p1))
1511 |                           p1 path via in input
1512 |                           settings-key settings)))))
1513 | 
1514 | (defn- re-gen [p overrides path rmap f]
1515 |   ;;(prn {:op op :ks ks :forms forms})
1516 |   (let [origp p
1517 |         {:keys [::s/op ps ks p1 p2 forms splice ret id ::s/gfn] :as p} (#'s/reg-resolve! p)
1518 |         rmap (if id (inck rmap id) rmap)
1519 |         ggens (fn [ps ks forms]
1520 |                 (let [gen (fn [p k f]
1521 |                             ;;(prn {:k k :path path :rmap rmap :op op :id id})
1522 |                             (when-not (and rmap id k (recur-limit? rmap id path k))
1523 |                               (if id
1524 |                                 (gen/delay (re-gen p overrides (if k (conj path k) path) rmap (or f p)))
1525 |                                 (re-gen p overrides (if k (conj path k) path) rmap (or f p)))))]
1526 |                   (map gen ps (or (seq ks) (repeat nil)) (or (seq forms) (repeat nil)))))]
1527 |     (or (when-let [gfn (or (get overrides (#'s/spec-name origp))
1528 |                                (get overrides (#'s/spec-name p) )
1529 |                                (get overrides path))]
1530 |             (case op
1531 |               (:accept nil) (gen/fmap vector (gfn))
1532 |               (gfn)))
1533 |           (when gfn
1534 |             (gfn))
1535 |           (when p
1536 |             (case op
1537 |               ::s/accept (if (= ret ::s/nil)
1538 |                          (gen/return [])
1539 |                          (gen/return [ret]))
1540 |               nil (when-let [g (#'s/gensub p overrides path rmap f)]
1541 |                     (gen/fmap vector g))
1542 |               ::s/amp (re-gen p1 overrides path rmap (op-describe p1))
1543 |               ::s/pcat (let [gens (ggens ps ks forms)]
1544 |                        (when (every? identity gens)
1545 |                          (apply gen/cat gens)))
1546 |               ::s/alt (let [gens (remove nil? (ggens ps ks forms))]
1547 |                       (when-not (empty? gens)
1548 |                         (gen/one-of gens)))
1549 |               ::s/rep (if (recur-limit? rmap id [id] id)
1550 |                       (gen/return [])
1551 |                       (when-let [g (re-gen p2 overrides path rmap forms)]
1552 |                         (gen/fmap #(apply concat %)
1553 |                                   (gen/vector g)))))))))
1554 | 
1555 | (defn- re-conform [p [x & xs :as data]]
1556 |   ;;(prn {:p p :x x :xs xs})
1557 |   (if (empty? data)
1558 |     (if (accept-nil? p)
1559 |       (let [ret (preturn p)]
1560 |         (if (= ret ::s/nil)
1561 |           nil
1562 |           ret))
1563 |       ::s/invalid)
1564 |     (if-let [dp (deriv p x)]
1565 |       (recur dp xs)
1566 |       ::s/invalid)))
1567 | 
1568 | (defn- re-explain [path via in re input settings-key settings]
1569 |   (loop [p re [x & xs :as data] input i 0]
1570 |     ;;(prn {:p p :x x :xs xs :re re}) (prn)
1571 |     (if (empty? data)
1572 |       (if (accept-nil? p)
1573 |         nil ;;success
1574 |         (op-explain (op-describe p) p path via in nil settings-key settings))
1575 |       (if-let [dp (deriv p x)]
1576 |         (recur dp xs (inc i))
1577 |         (if (accept? p)
1578 |           (if (= (::s/op p) ::s/pcat)
1579 |             (op-explain (op-describe p) p path via (conj in i) (seq data) settings-key settings)
1580 |             [{:path path
1581 |               :reason "Extra input"
1582 |               :pred (op-describe re)
1583 |               :val data
1584 |               :via via
1585 |               :in (conj in i)}])
1586 |           (or (op-explain (op-describe p) p path via (conj in i) (seq data) settings-key settings)
1587 |                 [{:path path
1588 |                   :reason "Extra input"
1589 |                   :pred (op-describe p)
1590 |                   :val data
1591 |                   :via via
1592 |                   :in (conj in i)}]))))))
1593 | 
1594 | (defmethod s/expand-spec `s/keys*
1595 |   [[_ & kspecs]]
1596 |   {:clojure.spec/op `s/keys*
1597 |    :specs (vec kspecs)})
1598 | 
1599 | (s/def ::s/kvs->map (s/conformer #(zipmap (map ::k %) (map ::v %)) #(map (fn [[k v]] {::k k ::v v}) %)))
1600 | 
1601 | (defmethod s/create-spec `s/keys*
1602 |   [{kspecs :specs}]
1603 |   (s/resolve-spec
1604 |     `(s/with-gen
1605 |        (s/& (s/* (s/cat ::k keyword? ::v any?))
1606 |             ::s/kvs->map
1607 |             (s/keys ~@kspecs))
1608 |        #(gen/fmap (fn [m#] (apply concat m#)) (s/gen (s/keys ~@kspecs))))))
1609 | 
1610 | ;;;;;;;;;;;;;;;;; HOFs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1611 | 
1612 | (defn- call-valid?
1613 |   [f specs args]
1614 |   (let [cargs (s/conform (:args specs) args)]
1615 |     (when-not (s/invalid? cargs)
1616 |       (let [ret (apply f args)
1617 |             cret (s/conform (:ret specs) ret)]
1618 |         (and (not (s/invalid? cret))
1619 |                (if (:fn specs)
1620 |                  (pvalid? (:fn specs) {:args cargs :ret cret})
1621 |                  true))))))
1622 | 
1623 | (defn- validate-fn
1624 |   "returns f if valid, else smallest"
1625 |   [f specs iters]
1626 |   (let [g (s/gen (:args specs))
1627 |         prop (gen/for-all* [g] #(call-valid? f specs %))]
1628 |     (let [ret (gen/quick-check iters prop)]
1629 |       (if-let [[smallest] (-> ret :shrunk :smallest)]
1630 |         smallest
1631 |         f))))
1632 | 
1633 | (defn- fspec-impl
1634 |   "Do not call this directly, use 'fspec'"
1635 |   [argspec aform retspec rform fnspec fform gfn]
1636 |   (let [specs {:args argspec :ret retspec :fn fnspec}]
1637 |     (reify
1638 |       clojure.lang.ILookup
1639 |       (valAt [this k] (get specs k))
1640 |       (valAt [_ k not-found] (get specs k not-found))
1641 | 
1642 |       Spec
1643 |       (conform* [this f settings-key settings]
1644 |         (if argspec
1645 |           (if (ifn? f)
1646 |             (if (identical? f (validate-fn f specs s/*fspec-iterations*)) f ::s/invalid)
1647 |             ::s/invalid)
1648 |           (throw (Exception. (str "Can't conform fspec without args spec: " (pr-str (s/describe this)))))))
1649 |       (unform* [_ f] f)
1650 |       (explain* [_ path via in f settings-key settings]
1651 |         (if (ifn? f)
1652 |           (let [args (validate-fn f specs 100)]
1653 |             (if (identical? f args) ;;hrm, we might not be able to reproduce
1654 |               nil
1655 |               (let [ret (try (apply f args) (catch Throwable t t))]
1656 |                 (if (instance? Throwable ret)
1657 |                   ;;TODO add exception data
1658 |                   [{:path path :pred '(apply fn) :val args :reason (.getMessage ^Throwable ret) :via via :in in}]
1659 | 
1660 |                   (let [cret (dt retspec ret rform)]
1661 |                     (if (s/invalid? cret)
1662 |                       (explain-1 rform retspec (conj path :ret) via in ret settings-key settings)
1663 |                       (when fnspec
1664 |                         (let [cargs (conform* argspec args nil settings)]
1665 |                           (explain-1 fform fnspec (conj path :fn) via in {:args cargs :ret cret} settings-key settings)))))))))
1666 |           [{:path path :pred 'ifn? :val f :via via :in in}]))
1667 |       (gen* [_ overrides _ _] (if gfn
1668 |                                 (gfn)
1669 |                                 (gen/return
1670 |                                   (fn [& args]
1671 |                                     (assert (pvalid? argspec args) (with-out-str (s/explain argspec args)))
1672 |                                     (gen/generate (s/gen retspec overrides))))))
1673 |       (with-gen* [_ gfn] (fspec-impl argspec aform retspec rform fnspec fform gfn))
1674 |       (describe* [_]
1675 |         (letfn [(clause-resolve ([[clause form]] (if form [clause (resolve-form form)] [])))]
1676 |           `(s/fspec ~@(mapcat clause-resolve [[:args aform] [:ret rform] [:fn fform]])))))))
1677 | 
1678 | (defmethod s/expand-spec `s/fspec
1679 |   [[_ & {:keys [args ret fn gen]}]]
1680 |   {:clojure.spec/op `s/fspec
1681 |    :args args
1682 |    :ret ret
1683 |    :fn fn
1684 |    :gen gen})
1685 | 
1686 | (defmethod s/create-spec `s/fspec
1687 |   [{:keys [args ret fn gen] :or {ret `any?}}]
1688 |   (fspec-impl (s/resolve-spec args) args
1689 |               (s/resolve-spec ret) ret
1690 |               (s/resolve-spec fn) fn (s/resolve-fn gen)))
1691 | 
1692 | (defn- nonconforming-impl
1693 |   ([spec]
1694 |     (nonconforming-impl spec nil))
1695 |   ([ospec gfn]
1696 |    (let [spec (delay (s/resolve-spec ospec))]
1697 |      (reify
1698 |        Spec
1699 |        (conform* [_ x settings-key settings]
1700 |          (let [ret (conform* @spec x settings-key settings)]
1701 |            (if (s/invalid? ret)
1702 |              ::s/invalid
1703 |              x)))
1704 |        (unform* [_ x] x)
1705 |        (explain* [_ path via in x settings-key settings]
1706 |          (explain* @spec path via in x settings-key settings))
1707 |        (gen* [_ overrides path rmap] (gen* @spec overrides path rmap))
1708 |        (with-gen* [_ gfn] (nonconforming-impl (nonconforming-impl spec gfn)))
1709 |        (describe* [_] `(s/nonconforming ~(resolve-form ospec)))))))
1710 | 
1711 | (defmethod s/expand-spec `s/nonconforming
1712 |   [[_ spec]]
1713 |   {:clojure.spec/op `s/nonconforming
1714 |    :spec spec})
1715 | 
1716 | (defmethod s/create-spec `s/nonconforming
1717 |   [{:keys [spec]}]
1718 |   (nonconforming-impl spec))
1719 | 
1720 | (defn- nilable-impl
1721 |   "Do not call this directly, use 'nilable'"
1722 |   [form gfn]
1723 |   (let [spec (delay (s/resolve-spec form))]
1724 |     (reify
1725 |       Spec
1726 |       (conform* [_ x settings-key settings] (if (nil? x) nil (conform* @spec x settings-key settings)))
1727 |       (unform* [_ x] (if (nil? x) nil (unform* @spec x)))
1728 |       (explain* [_ path via in x settings-key settings]
1729 |         (when-not (or (pvalid? @spec x) (nil? x))
1730 |           (conj
1731 |             (explain-1 (s/form @spec) @spec (conj path ::s/pred) via in x nil settings)
1732 |             {:path (conj path ::s/nil) :pred 'nil? :val x :via via :in in})))
1733 |       (gen* [_ overrides path rmap]
1734 |         (if gfn
1735 |           (gfn)
1736 |           (gen/frequency
1737 |             [[1 (gen/delay (gen/return nil))]
1738 |              [9 (gen/delay (#'s/gensub @spec overrides (conj path ::s/pred) rmap (s/form @spec)))]])))
1739 |       (with-gen* [_ gfn] (nilable-impl form gfn))
1740 |       (describe* [_] `(s/nilable ~(resolve-form form))))))
1741 | 
1742 | (defmethod s/expand-spec `s/nilable
1743 |   [[_ pred]]
1744 |   {:clojure.spec/op `s/nilable
1745 |    :spec pred})
1746 | 
1747 | (defmethod s/create-spec `s/nilable
1748 |   [{:keys [spec]}]
1749 |   (nilable-impl spec nil))
1750 | 


--------------------------------------------------------------------------------