ajet/df-research
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

init research

Browse Source
This commit is contained in:
Adam Jeniski
2026-02-08 11:20:43 -10:00
commit bdf064f54d
3041 changed files with 1592200 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
malli/.github/workflows/clojure.yml
Vendored
+137
View File
@@ -0,0 +1,137 @@
---
name: Run tests
on:
push:
branches: [master]
pull_request:
branches: [master]
jobs:
build-clj:
strategy:
matrix:
# Supported Java versions: LTS releases and latest
jdk: [8, 11, 17, 21, 25]
clojure: [11, 12]
name: Clojure ${{ matrix.clojure }} (Java ${{ matrix.jdk }})
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v5
- name: Setup Java ${{ matrix.jdk }}
uses: actions/setup-java@v5
with:
distribution: zulu
java-version: ${{ matrix.jdk }}
- uses: actions/cache@v4
with:
path: |
~/.m2/repository
~/.gitlibs
key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ matrix.clojure }}-${{ matrix.jdk }}
restore-keys: |
${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ matrix.clojure }}-
${{ runner.os }}-test-deps-
- name: Setup Clojure
uses: DeLaGuardo/setup-clojure@master
with:
cli: latest
- name: Run tests
run: CLOJURE_ALIAS=clojure-${{ matrix.clojure }} bin/kaocha
build-cljs:
name: ClojureScript
strategy:
matrix:
mode: [none, advanced, cherry-none, cherry-advanced]
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v5
- name: Setup Java 11
uses: actions/setup-java@v5
with:
distribution: zulu
java-version: 11
- uses: actions/cache@v4
with:
path: |
~/.m2/repository
~/.gitlibs
key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}
restore-keys: |
${{ runner.os }}-test-deps-
- name: Setup Clojure
uses: DeLaGuardo/setup-clojure@master
with:
cli: latest
- name: Setup Node.js
uses: actions/setup-node@v5
with:
node-version: 16
- name: Install dependencies
run: npm ci
- name: Run tests on ${{ matrix.mode }}
run: bin/node ${{ matrix.mode }}
build-bb:
name: Babashka
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v5
- name: Setup Java 11
uses: actions/setup-java@v5
with:
distribution: zulu
java-version: 11
- uses: actions/cache@v4
with:
path: |
~/.m2/repository
~/.deps.clj
~/.gitlibs
key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ hashFiles('**/bb.edn') }}
restore-keys: |
${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-
${{ runner.os }}-test-deps-
- name: Setup Clojure
uses: DeLaGuardo/setup-clojure@master
with:
cli: latest
bb: latest
- name: Run tests
run: bb test-bb
doc-tests:
# Builds tests from Documentation with test-doc-blocks and tests that
# the examples are still valid.
name: Doc Tests
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v5
- name: Setup Java 25
uses: actions/setup-java@v5
with:
distribution: zulu
java-version: 25
- uses: actions/cache@v4
with:
path: |
~/.m2/repository
~/.deps.clj
~/.gitlibs
key: ${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-${{ hashFiles('**/bb.edn') }}
restore-keys: |
${{ runner.os }}-test-deps-${{ hashFiles('**/deps.edn') }}-
${{ runner.os }}-test-deps-
- name: Setup Clojure
uses: DeLaGuardo/setup-clojure@master
with:
cli: latest
bb: latest
- name: Run doc tests
run: bb test-docs
malli/.github/workflows/release.yml
Vendored
+28
View File
@@ -0,0 +1,28 @@
name: Release
on:
release:
types:
- published # reacts to releases and prereleases, but not their drafts
jobs:
build-and-release:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v5
- name: "Setup Java"
uses: actions/setup-java@v5
with:
distribution: zulu
java-version: 8
- name: "Setup Clojure"
uses: DeLaGuardo/setup-clojure@master
with:
cli: latest
- name: Build jar
run: clojure -M:jar
- name: Deploy to Clojars
run: clojure -X:deploy
env:
CLOJARS_USERNAME: metosinci
CLOJARS_PASSWORD: "${{ secrets.CLOJARS_DEPLOY_TOKEN }}"
malli/.gitignore
Vendored
+20
View File
@@ -0,0 +1,20 @@
*.iml
.cljs_node_repl
.cpcache
.idea
node_modules
out
.nrepl-port
.dir-locals.el
cljs-test-runner-out
*.jar
classes
/demo
/demosci
/target
.clj-kondo
.clerk
.shadow-cljs
public/*
!public/index.html
.cache
malli/.lsp/config.edn
Vendored
+3
View File
@@ -0,0 +1,3 @@
{:cljfmt {:indents {for-all [[:inner 0]]
are [[:inner 0]]}}
:clean {:ns-inner-blocks-indentation :same-line}}
malli/CHANGELOG.md
Vendored
+1012
View File
File diff suppressed because it is too large Load Diff
malli/CONTRIBUTING.md
Vendored
+40
View File
@@ -0,0 +1,40 @@
# How to contribute
Contributions are welcome!
* Please file bug reports and feature requests to https://github.com/metosin/malli/issues
* For small changes, such as bug fixes or documentation changes, feel free to send a pull request
* If you want to make a big change or implement a big new feature, please open an issue to discuss it first
If you have questions about contributing or about malli in general, join the [#malli](https://clojurians.slack.com/messages/malli/) channel in [Clojurians Slack](http://clojurians.net/).
## Environment setup
1. Clone this git repository
2. Have [Clojure installed](https://clojure.org/guides/getting_started)
## Performance
* Code should be performant for the selected code paths. These include: `m/-validator`, `m/-explainer` and `-transformer`
* See `perf/malli` for existing perf tests
## Making changes
* Fork the repository on Github
* Create a topic branch from where you want to base your work (usually the master branch)
* Check the formatting rules from existing code (no trailing whitespace, mostly default indentation)
* Ensure any new code is well-tested, and if possible, any issue fixed is covered by one or more new tests
* Verify that all tests pass using `./bin/kaocha` and `./bin/node`
* Push your code to your fork of the repository
* Make a Pull Request
## Commit messages
1. Separate subject from body with a blank line
2. Limit the subject line to 50 characters
3. Capitalize the subject line
4. Do not end the subject line with a period
5. Use the imperative mood in the subject line
- "Add x", "Fix y", "Support z", "Remove x"
6. Wrap the body at 72 characters
7. Use the body to explain what and why vs. how
malli/LICENSE
Vendored
+277
View File
@@ -0,0 +1,277 @@
Eclipse Public License - v 2.0
THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE
PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION
OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT.
1. DEFINITIONS
"Contribution" means:
a) in the case of the initial Contributor, the initial content
Distributed under this Agreement, and
b) in the case of each subsequent Contributor:
i) changes to the Program, and
ii) additions to the Program;
where such changes and/or additions to the Program originate from
and are Distributed by that particular Contributor. A Contribution
"originates" from a Contributor if it was added to the Program by
such Contributor itself or anyone acting on such Contributor's behalf.
Contributions do not include changes or additions to the Program that
are not Modified Works.
"Contributor" means any person or entity that Distributes the Program.
"Licensed Patents" mean patent claims licensable by a Contributor which
are necessarily infringed by the use or sale of its Contribution alone
or when combined with the Program.
"Program" means the Contributions Distributed in accordance with this
Agreement.
"Recipient" means anyone who receives the Program under this Agreement
or any Secondary License (as applicable), including Contributors.
"Derivative Works" shall mean any work, whether in Source Code or other
form, that is based on (or derived from) the Program and for which the
editorial revisions, annotations, elaborations, or other modifications
represent, as a whole, an original work of authorship.
"Modified Works" shall mean any work in Source Code or other form that
results from an addition to, deletion from, or modification of the
contents of the Program, including, for purposes of clarity any new file
in Source Code form that contains any contents of the Program. Modified
Works shall not include works that contain only declarations,
interfaces, types, classes, structures, or files of the Program solely
in each case in order to link to, bind by name, or subclass the Program
or Modified Works thereof.
"Distribute" means the acts of a) distributing or b) making available
in any manner that enables the transfer of a copy.
"Source Code" means the form of a Program preferred for making
modifications, including but not limited to software source code,
documentation source, and configuration files.
"Secondary License" means either the GNU General Public License,
Version 2.0, or any later versions of that license, including any
exceptions or additional permissions as identified by the initial
Contributor.
2. GRANT OF RIGHTS
a) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free copyright
license to reproduce, prepare Derivative Works of, publicly display,
publicly perform, Distribute and sublicense the Contribution of such
Contributor, if any, and such Derivative Works.
b) Subject to the terms of this Agreement, each Contributor hereby
grants Recipient a non-exclusive, worldwide, royalty-free patent
license under Licensed Patents to make, use, sell, offer to sell,
import and otherwise transfer the Contribution of such Contributor,
if any, in Source Code or other form. This patent license shall
apply to the combination of the Contribution and the Program if, at
the time the Contribution is added by the Contributor, such addition
of the Contribution causes such combination to be covered by the
Licensed Patents. The patent license shall not apply to any other
combinations which include the Contribution. No hardware per se is
licensed hereunder.
c) Recipient understands that although each Contributor grants the
licenses to its Contributions set forth herein, no assurances are
provided by any Contributor that the Program does not infringe the
patent or other intellectual property rights of any other entity.
Each Contributor disclaims any liability to Recipient for claims
brought by any other entity based on infringement of intellectual
property rights or otherwise. As a condition to exercising the
rights and licenses granted hereunder, each Recipient hereby
assumes sole responsibility to secure any other intellectual
property rights needed, if any. For example, if a third party
patent license is required to allow Recipient to Distribute the
Program, it is Recipient's responsibility to acquire that license
before distributing the Program.
d) Each Contributor represents that to its knowledge it has
sufficient copyright rights in its Contribution, if any, to grant
the copyright license set forth in this Agreement.
e) Notwithstanding the terms of any Secondary License, no
Contributor makes additional grants to any Recipient (other than
those set forth in this Agreement) as a result of such Recipient's
receipt of the Program under the terms of a Secondary License
(if permitted under the terms of Section 3).
3. REQUIREMENTS
3.1 If a Contributor Distributes the Program in any form, then:
a) the Program must also be made available as Source Code, in
accordance with section 3.2, and the Contributor must accompany
the Program with a statement that the Source Code for the Program
is available under this Agreement, and informs Recipients how to
obtain it in a reasonable manner on or through a medium customarily
used for software exchange; and
b) the Contributor may Distribute the Program under a license
different than this Agreement, provided that such license:
i) effectively disclaims on behalf of all other Contributors all
warranties and conditions, express and implied, including
warranties or conditions of title and non-infringement, and
implied warranties or conditions of merchantability and fitness
for a particular purpose;
ii) effectively excludes on behalf of all other Contributors all
liability for damages, including direct, indirect, special,
incidental and consequential damages, such as lost profits;
iii) does not attempt to limit or alter the recipients' rights
in the Source Code under section 3.2; and
iv) requires any subsequent distribution of the Program by any
party to be under a license that satisfies the requirements
of this section 3.
3.2 When the Program is Distributed as Source Code:
a) it must be made available under this Agreement, or if the
Program (i) is combined with other material in a separate file or
files made available under a Secondary License, and (ii) the initial
Contributor attached to the Source Code the notice described in
Exhibit A of this Agreement, then the Program may be made available
under the terms of such Secondary Licenses, and
b) a copy of this Agreement must be included with each copy of
the Program.
3.3 Contributors may not remove or alter any copyright, patent,
trademark, attribution notices, disclaimers of warranty, or limitations
of liability ("notices") contained within the Program from any copy of
the Program which they Distribute, provided that Contributors may add
their own appropriate notices.
4. COMMERCIAL DISTRIBUTION
Commercial distributors of software may accept certain responsibilities
with respect to end users, business partners and the like. While this
license is intended to facilitate the commercial use of the Program,
the Contributor who includes the Program in a commercial product
offering should do so in a manner which does not create potential
liability for other Contributors. Therefore, if a Contributor includes
the Program in a commercial product offering, such Contributor
("Commercial Contributor") hereby agrees to defend and indemnify every
other Contributor ("Indemnified Contributor") against any losses,
damages and costs (collectively "Losses") arising from claims, lawsuits
and other legal actions brought by a third party against the Indemnified
Contributor to the extent caused by the acts or omissions of such
Commercial Contributor in connection with its distribution of the Program
in a commercial product offering. The obligations in this section do not
apply to any claims or Losses relating to any actual or alleged
intellectual property infringement. In order to qualify, an Indemnified
Contributor must: a) promptly notify the Commercial Contributor in
writing of such claim, and b) allow the Commercial Contributor to control,
and cooperate with the Commercial Contributor in, the defense and any
related settlement negotiations. The Indemnified Contributor may
participate in any such claim at its own expense.
For example, a Contributor might include the Program in a commercial
product offering, Product X. That Contributor is then a Commercial
Contributor. If that Commercial Contributor then makes performance
claims, or offers warranties related to Product X, those performance
claims and warranties are such Commercial Contributor's responsibility
alone. Under this section, the Commercial Contributor would have to
defend claims against the other Contributors related to those performance
claims and warranties, and if a court requires any other Contributor to
pay any damages as a result, the Commercial Contributor must pay
those damages.
5. NO WARRANTY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS"
BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR
IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF
TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR
PURPOSE. Each Recipient is solely responsible for determining the
appropriateness of using and distributing the Program and assumes all
risks associated with its exercise of rights under this Agreement,
including but not limited to the risks and costs of program errors,
compliance with applicable laws, damage to or loss of data, programs
or equipment, and unavailability or interruption of operations.
6. DISCLAIMER OF LIABILITY
EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT
PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS
SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST
PROFITS), HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OR DISTRIBUTION OF THE PROGRAM OR THE
EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
7. GENERAL
If any provision of this Agreement is invalid or unenforceable under
applicable law, it shall not affect the validity or enforceability of
the remainder of the terms of this Agreement, and without further
action by the parties hereto, such provision shall be reformed to the
minimum extent necessary to make such provision valid and enforceable.
If Recipient institutes patent litigation against any entity
(including a cross-claim or counterclaim in a lawsuit) alleging that the
Program itself (excluding combinations of the Program with other software
or hardware) infringes such Recipient's patent(s), then such Recipient's
rights granted under Section 2(b) shall terminate as of the date such
litigation is filed.
All Recipient's rights under this Agreement shall terminate if it
fails to comply with any of the material terms or conditions of this
Agreement and does not cure such failure in a reasonable period of
time after becoming aware of such noncompliance. If all Recipient's
rights under this Agreement terminate, Recipient agrees to cease use
and distribution of the Program as soon as reasonably practicable.
However, Recipient's obligations under this Agreement and any licenses
granted by Recipient relating to the Program shall continue and survive.
Everyone is permitted to copy and distribute copies of this Agreement,
but in order to avoid inconsistency the Agreement is copyrighted and
may only be modified in the following manner. The Agreement Steward
reserves the right to publish new versions (including revisions) of
this Agreement from time to time. No one other than the Agreement
Steward has the right to modify this Agreement. The Eclipse Foundation
is the initial Agreement Steward. The Eclipse Foundation may assign the
responsibility to serve as the Agreement Steward to a suitable separate
entity. Each new version of the Agreement will be given a distinguishing
version number. The Program (including Contributions) may always be
Distributed subject to the version of the Agreement under which it was
received. In addition, after a new version of the Agreement is published,
Contributor may elect to Distribute the Program (including its
Contributions) under the new version.
Except as expressly stated in Sections 2(a) and 2(b) above, Recipient
receives no rights or licenses to the intellectual property of any
Contributor under this Agreement, whether expressly, by implication,
estoppel or otherwise. All rights in the Program not expressly granted
under this Agreement are reserved. Nothing in this Agreement is intended
to be enforceable by any entity that is not a Contributor or Recipient.
No third-party beneficiary rights are created under this Agreement.
Exhibit A - Form of Secondary Licenses Notice
"This Source Code may also be made available under the following
Secondary Licenses when the conditions for such availability set forth
in the Eclipse Public License, v. 2.0 are satisfied: {name license(s),
version(s), and exceptions or additional permissions here}."
Simply including a copy of this Agreement, including this Exhibit A
is not sufficient to license the Source Code under Secondary Licenses.
If it is not possible or desirable to put the notice in a particular
file, then You may include the notice in a location (such as a LICENSE
file in a relevant directory) where a recipient would be likely to
look for such a notice.
You may add additional accurate notices of copyright ownership.
malli/README.md
Vendored
+4155
View File
File diff suppressed because it is too large Load Diff
malli/app/malli/app.cljc
Vendored
+10
View File
@@ -0,0 +1,10 @@
;; this file is used to view the generated bundle sizes
;; - npx shadow-cljs run shadow.cljs.build-report app /tmp/report.html
;; - npx shadow-cljs release app --pseudo-names
(ns malli.app
(:require [malli.core :as m]))
(m/validate
[:map [:maybe [:maybe :string]]]
{:maybe "sheep"})
; => true
malli/app/malli/app2.cljc
Vendored
+28
View File
@@ -0,0 +1,28 @@
;; this file is used to view the generated bundle sizes
;; - npx shadow-cljs run shadow.cljs.build-report app2 /tmp/report.html
;; - npx shadow-cljs release app2 --pseudo-names
(ns malli.app2
(:require [malli.core :as m]
[malli.registry :as mr]))
;; - cljs: :closure-defines {malli.registry/type "custom"}
;; - clj: :jvm-opts ["-Dmalli.registry/type=custom"]
;; just what is needed (1.2kb gzipped)
(def registry
{:string (m/-string-schema)
:maybe (m/-maybe-schema)
:map (m/-map-schema)})
(m/validate
[:map [:maybe [:maybe :string]]]
{:maybe "sheep"}
{:registry registry})
; => true
(mr/set-default-registry! registry)
(m/validate
[:map [:maybe [:maybe :string]]]
{:maybe "sheep"})
; => true
malli/app/malli/dev_preload.cljs
Vendored
+7
View File
@@ -0,0 +1,7 @@
(ns malli.dev-preload
{:dev/always true}
(:require
[malli.instrument-app]
[malli.dev.cljs :as dev]))
(dev/start!)
malli/app/malli/helpers.cljs
Vendored
+11
View File
@@ -0,0 +1,11 @@
(ns malli.helpers)
(def defs-small-int
[:int {:max 6}])
(def int-schema :int)
(defn x+y
{:malli/schema [:=> [:cat float? float?] :double]}
[x y]
(+ x y))
malli/app/malli/helpers2.cljs
Vendored
+55
View File
@@ -0,0 +1,55 @@
(ns malli.helpers2
(:require
[malli.experimental :as mx]
[malli.core :as m]
[malli.helpers :as h :refer [int-schema]]))
(mx/defn square-it :- h/int-schema
[x :- int?]
(str x)
;(str (* x x))
)
;(mx/defn f1 [] 1)
;(mx/defn f3 [x :- :int] x)
;(mx/defn f4 :- [:int {:min 0}]
; "int int -> int functions"
; [x :- [:int {:min 0}], y :- :int]
; (+ x y))
(def AB [:map [:a [:int {:min 0}]] [:b :int]])
(def CD [:map [:c [:int {:min 0}]] [:d :int]])
;; schematized, nested keywords args
(mx/defn f5 :- [:cat :int :int :int :int AB CD]
"Nested Keyword argument"
[[& {:keys [a b] :as m1} :- AB]
& {:keys [c d] :as m2} :- CD]
[a b c d m1 m2])
(mx/defn f3 [x :- :int] x)
(comment
(macroexpand
'(mx/defn f3 [x :- :int] x))
(macroexpand
'(mx/defn f5 :- [:cat :int :int :int :int AB CD]
"Nested Keyword argument"
[[& {:keys [a b] :as m1} :- AB]
& {:keys [c d] :as m2} :- CD]
[a b c d m1 m2])))
;(defn square-it [x] (* x x))
;(m/=> square-it [:=> [:cat h/int-schema] int-schema])
;(mx/defn square-it2 :- :int ; h/int-schema
; [x :- :int]
; (* x x))
;(comment
; (macroexpand
; '(m/=> square-it [:=> [:cat h/int-schema] :int])
; )
; (macroexpand-1
; '(mx/defn square-it :- :int ; h/int-schema
; [x :- :int]
; (* x x))
; ))
malli/app/malli/instrument_app.cljs
Vendored
+220
View File
@@ -0,0 +1,220 @@
(ns malli.instrument-app
(:require
[malli.instrument :as mi-new]
malli.helpers
[malli.core :as m]
[clojure.test.check.generators :as gen]
[malli.experimental.time.generator]
[malli.dev.pretty :as pretty]
[malli.generator :as mg]
[malli.experimental :as mx]
[malli.experimental.time :as time]))
(js/console.log "now: " (time/LocalDate.now))
(js/console.log "generated: "
(gen/sample (mg/-schema-generator (time/-local-date-time-schema) nil) 10))
(js/console.log
(into-array
(mg/sample :time/zoned-date-time {:registry (merge (m/default-schemas) (time/schemas))})))
(mx/defn my-ex-fn :- [:int]
[a :- :string] (+ 5 a))
(mx/defn my-ex-fn2 :- [:double]
([a :- :string] (+ 5 a))
([a :- :string, b :- :double] (+ 5 a b)))
(defn init [] (js/console.log "INIT!"))
(defn x+y
{:malli/schema [:=> [:cat float? float?] :double]}
[x y]
(+ x y))
;(defn add-dates [a b]
; {:malli/schema [:=> [:cat :time/local-date :time/local-date] :time/local-date]}
(defn sum [a b] (+ a b))
(def sum2
(m/-instrument {:schema (m/schema [:=> [:cat :int :int] :int])
:report (pretty/reporter)}
sum))
;(m/=> sum [:=> [:cat :int :int] :int])
(set! sum
(m/-instrument {:schema (m/schema [:=> [:cat :int :int] :int])
:report (pretty/reporter)}
sum))
(defn minus
"a normal clojure function, no dependencies to malli"
;{:malli/schema [:=> [:cat :int] [:int {:min 6}]]
; :malli/gen true
; :malli/scope #{:input :output}}
[x]
(dec x))
(defn plus-gen
;{:malli/schema [:=> [:cat :int] [:int {:min 6}]]}
[x]
(dec x))
;(comment
; @mi/instrumented-vars
; ((get @mi/instrumented-vars `sum) 1 "2"))
(defn plus1 [a] (inc a))
;(m/=> plus1 [:=> [:cat :int] :int])
(defn plus2
{:validate? true}
[a b]
(+ a b))
;(m/=> plus2 [:=> [:cat :string :int] :int])
;; multi-arity function
(defn plus-many
{:malli/schema
[:function
[:=> [:cat :int] :int]
[:=> [:cat :int :int [:* :int]] :int]]}
([a] (inc a))
([a b & others]
(apply + a b others)))
(defn a-fun {:malli/schema [:=> [:cat :int] :int]} [a] (+ 5 a))
(defn a-fun2 {:malli/schema [:=> [:cat :string] :int]} [a] (+ 5 a))
;(m/=> plus-many
; [:function
; [:=> [:cat :int] :int]
; [:=> [:cat :int :int [:* :int]] :int]])
(def pow-gen
(m/-instrument
{:schema [:function
[:=> [:cat :int] [:int {:max 6}]]
[:=> [:cat :int :int] [:int {:max 6}]]]
:gen mg/generate}))
(defn minus2
"kukka"
{:malli/schema [:=> [:cat :int] [:int {:min 6}]]
:malli/scope #{:input :output}}
[x] (dec x))
(defn ->minus [] minus2)
(defn minus-test [x] (dec x))
(defn plus-it [x] (inc x))
;(m/=> plus-it [:=> [:cat :int] [:int {:max 6}]])
(defn sum3 [a b] (+ a b))
(comment (meta sum3))
(m/=> sum3 [:=> [:cat :int :int] :int])
(def small-int [:int {:max 6}])
(def MyInt (m/-simple-schema {:type 'MyInt, :pred #(and (int? %) (< 100 %))}))
;(defn plus [x] (inc x))
;(m/=> plus [:=> [:cat :int] small-int])
(defn plusX [x] (inc x))
;(m/=> plusX [:=> [:cat :int] MyInt])
(defn my-function-bad
{:malli/schema [:=> [:cat :int [:* :int]] :any]}
[x & args]
(prn "X is " x " args are " args)
123)
(defn pure-vary
{:malli/schema [:=> [:cat [:* :string]] some?]}
[& x] x)
(defn multi-arity-variadic-fn
{:malli/schema
[:function
;[:=> [:cat] [:int]]
[:=> [:cat :int] [:int]]
[:=> [:cat :string :string] [:string]]
[:=> [:cat :string :string :string [:* :string]] [:string]]]}
([] 500)
([a] (inc a))
([a b] (str a b))
([a b c & more] (str a b c more)))
(defn plus [x] (inc x))
(m/=> plus [:=> [:cat :int] [:int {:max 6}]])
(defn try-it []
(println "in try-it")
;(minus2 1)
(plus-many 5 8 1 0 20)
;(pure-vary "hi" 50)
;(malli.helpers/x+y "hi" 5)
;(plus-many 5 8 1 "0" 20)
;(mi-new/unstrument!)
;(plus "2")
;(str-join-mx2 [2])
(println "after ")
;(plus-many 5 8 1 "0" 20)
;(plus-many "hi")
(my-function-bad 1)
(my-function-bad 1 5)
(my-function-bad 1 nil)
;(pure-vary "hi" 5)
(multi-arity-variadic-fn "a" "b")
;; works b/c there is no schema for this arity:
;(multi-arity-variadic-fn 'a "b" )
;; fails as it hits the last fn schema
(multi-arity-variadic-fn 'a "b" "b")
;(multi-arity-variadic-fn "a" "b" "c" :x)
)
(macroexpand '(mi-new/collect! {:ns ['malli.instrument-app 'malli.instrument-test 'malli.instrument.fn-schemas]}))
(defn ^:dev/after-load x []
(println "AFTER LOAD - malli.dev.cljs/start!")
;(m/-deregister-metadata-function-schemas! :cljs)
;(dev/collect-all!)
;(mi-new/collect!)
;(mi-new/collect! {:ns [
; 'malli.instrument-app
; 'malli.instrument-test 'malli.instrument.fn-schemas]})
;
;(mi-new/unstrument!)
;(mi-new/instrument! {:filters [
; (mi-new/-filter-ns 'malli.instrument-test 'malli.instrument.fn-schemas 'malli.instrument-app)
; ;(mi-new/-filter-schema (fn [s] (println "FILTER SCHEMA: " s)))
; ;(mi-new/-filter-var
; ; #{#'str-join}
; ; ;(fn [x] (= x #'str-join))
; ; )
; ]
; ;:skip-instrumented? true
;
; :report (pretty/thrower)})
;(dev/start!)
;(mi.old/instrument!)
;(js/setTimeout try-it 100)
)
(comment
(macroexpand
'(dev/start!))
(m/function)
(@(Var. (constantly str-join) 'str-join {:metadata 'here}) [1 2])
(= (Var. (constantly str-join) `str-join {:metadata 'here})
#'str-join)
(macroexpand '(dev/collect-all!))
(macroexpand '(mi-new/collect-all!))
(mi-new/-pure-variadic? plus-many)
(mi-new/-pure-variadic? pure-vary)
(mi-new/-pure-variadic? my-function-bad))
malli/bb.edn
Vendored
+44
View File
@@ -0,0 +1,44 @@
{:deps {metosin/malli {:local/root "."}}
:tasks
{test-clj {:doc "Run JVM Clojure tests with kaocha"
:task (apply clojure {:extra-env {"TEST_SCI" "true"}}
(str "-A:" (System/getenv "CLOJURE"))
"-M:test" "-m" "kaocha.runner" *command-line-args*)}
test-cljs {:doc "Run ClojureScript tests"
:task (do
(println "Running CLJS tests without optimizations")
(apply clojure {:extra-env {"TEST_SCI" "true"}}
"-M:test:cljs-test-runner:test-sci" "-c" "{:optimizations :none}"
*command-line-args*)
(println "Running CLJS tests with optimizations")
(apply clojure {:extra-env {"TEST_SCI" "true"}}
"-M:test:cljs-test-runner:test-sci" "-c" "{:optimizations :advanced}"
"-e" ":simple"
*command-line-args*))}
test-cherry {:doc "Run CLJS tests with cherry"
:task (do (println "Running CLJS tests with cherry, without optimizations")
(apply clojure "-M:test:cljs-test-runner:cherry:test-cherry" "-c"
(str {:optimizations :none})
*command-line-args*)
(println "Running CLJS tests with cherry, with optimizations")
(apply clojure "-M:test:cljs-test-runner:cherry:test-cherry" "-c"
(str {:optimizations :advanced,
;; see https://clojure.atlassian.net/browse/CLJS-3401
:optimize-constants false})
"-e" ":simple"
*command-line-args*))}
test-bb {:doc "Run Babashka tests"
:extra-deps {org.babashka/spec.alpha {:git/url "https://github.com/babashka/spec.alpha"
:git/sha "b6eb0f2208ab036c0a5d0e7235cb0b09d2feabb7"}}
:extra-paths ["src" "test"]
:task bb-test-runner/run-tests}
test-docs {:doc "Run README.md based tests"
:task (do
(println "Generating tests from README.md")
(clojure "-X:test-doc-blocks")
(println "Running tests")
(clojure "-M:test:test-doc-test" "-m" "kaocha.runner" "--config-file" "test-doc-tests.edn" "generated"))}}}
malli/bin/install
Vendored Executable
+5
View File
@@ -0,0 +1,5 @@
#!/bin/bash
set -xe
clojure -M:jar && clojure -M:install
malli/bin/kaocha
Vendored Executable
+3
View File
@@ -0,0 +1,3 @@
#!/usr/bin/env bash
# Should work if the env var is empty
clojure -M:test:$CLOJURE_ALIAS -m kaocha.runner "$@"
malli/bin/native-image
Vendored Executable
+31
View File
@@ -0,0 +1,31 @@
#!/usr/bin/env bash
set -eo pipefail
if [ -z "$1" ]; then
echo "Usage: native-image demo|demosci"
exit 1
fi
mkdir -p classes
clojure -J-Dborkdude.dynaload.aot=true -A:graalvm -e "(compile 'malli.graalvm.$1)"
# java -cp "$(clojure -A:graalvm -Spath):classes" malli.graalvm.demo
if [ -z "$GRAALVM_HOME" ]; then
echo "Please set $GRAALVM_HOME"
exit 1
fi
"$GRAALVM_HOME/bin/native-image" \
-cp "$(clojure -A:graalvm -Spath):classes" \
-H:Name=$1 \
-J-Dborkdude.dynaload.aot=true \
-H:+ReportExceptionStackTraces \
--initialize-at-build-time \
--report-unsupported-elements-at-runtime \
--verbose \
--no-fallback \
--no-server \
"-J-Xmx3g" \
malli.graalvm.$1
malli/bin/node
Vendored Executable
+32
View File
@@ -0,0 +1,32 @@
#!/usr/bin/env bash
set -eo pipefail
none() {
echo 'Running CLJS test in Node with optimizations :none'
TEST_SCI=true clojure -M:test:cljs-test-runner:sci:test-sci -c '{:optimizations :none}' "$@"
}
advanced() {
echo 'Running CLJS test in Node with optimizations :advanced'
TEST_SCI=true clojure -M:test:cljs-test-runner:sci:test-sci -c '{:optimizations :advanced}' -e :simple "$@"
}
cherry-none() {
echo 'Running CLJS test in Node with cherry + optimizations :none'
clojure -M:test:cljs-test-runner:cherry:test-cherry -c '{:optimizations :none}' "$@"
}
cherry-advanced() {
echo 'Running CLJS test in Node with cherry + optimizations :advanced'
# :optimize-constants is set to false until https://clojure.atlassian.net/browse/CLJS-3401 is fixed
clojure -M:test:cljs-test-runner:cherry:test-cherry -c '{:optimizations :advanced :optimize-constants false}' -e :simple "$@"
}
case $1 in
none) none ;;
advanced) advanced ;;
cherry-none) cherry-none ;;
cherry-advanced) cherry-advanced ;;
*) none; advanced; cherry; cherry-advanced ;;
esac
malli/bin/repl
Vendored Executable
+3
View File
@@ -0,0 +1,3 @@
#!/usr/bin/env bash
set -ex
clojure -M:shadow:rebel:test -m rebel-readline.main
malli/build.clj
Vendored
+33
View File
@@ -0,0 +1,33 @@
(ns build
(:require [clojure.tools.build.api :as b]))
(def lib 'metosin/malli)
(def version (format "0.6.%s" (b/git-count-revs nil)))
(def class-dir "target/classes")
(def basis (b/create-basis {:project "deps.edn"}))
(def uber-file "target/uber.jar")
(defn clean [_]
(b/delete {:path "target"}))
(defn prep [_]
(b/write-pom {:class-dir class-dir
:lib lib
:version version
:basis basis
:src-dirs ["src"]})
(b/copy-dir {:src-dirs ["src" "resources"]
:target-dir class-dir}))
(defn uber [_]
(b/compile-clj {:basis basis
:src-dirs ["src"]
:class-dir class-dir})
(b/uber {:class-dir class-dir
:uber-file uber-file
:basis basis}))
(defn all [_]
(clean nil) (prep nil) (uber nil))
malli/deps.edn
Vendored
+94
View File
@@ -0,0 +1,94 @@
{:paths ["src" "resources"]
:deps {org.clojure/clojure {:mvn/version "1.12.3"}
borkdude/dynaload {:mvn/version "0.3.5"}
borkdude/edamame {:mvn/version "1.4.32"}
org.clojure/test.check {:mvn/version "1.1.1"}
;; pretty errors, optional deps
fipp/fipp {:mvn/version "0.6.29"}
mvxcvi/arrangement {:mvn/version "2.1.0"}}
:aliases {:test {:extra-paths ["test"]
:extra-deps {com.gfredericks/test.chuck {:mvn/version "0.2.15"}
lambdaisland/kaocha {:mvn/version "1.91.1392"}
lambdaisland/kaocha-cljs {:mvn/version "1.5.154"}
org.babashka/sci {:mvn/version "0.10.49"}
lambdaisland/kaocha-junit-xml {:mvn/version "1.17.101"}
metosin/spec-tools {:mvn/version "0.10.7"}
spec-provider/spec-provider {:mvn/version "0.4.14"}
metosin/schema-tools {:mvn/version "0.13.1"}
metosin/jsonista {:mvn/version "0.3.13"}
prismatic/schema {:mvn/version "1.4.1"}
minimallist/minimallist {:mvn/version "0.0.10"}
net.cgrand/seqexp {:mvn/version "0.6.2"}
djblue/portal {:mvn/version "0.61.0"}
meta-merge/meta-merge {:mvn/version "1.0.0"}
expound/expound {:mvn/version "0.9.0"}
lambdaisland/deep-diff {:mvn/version "0.0-47"}
com.bhauman/spell-spec {:mvn/version "0.1.2"}
org.clojure/spec-alpha2 {:git/url "https://github.com/clojure/spec-alpha2.git"
:sha "eb94e46853d90153ba6dc72a4093719f38a90a4a"}}}
:clojure-11 {:extra-deps {org.clojure/clojure {:mvn/version "1.11.3"}}}
:clojure-12 {}
:sci {:extra-deps {org.babashka/sci {:mvn/version "0.10.49"}}}
:cherry {:extra-deps {io.github.squint-cljs/cherry {:git/tag "v0.4.30" :git/sha "9d253be"}}}
:test-sci {:extra-paths ["test-sci"]
:main-opts ["-m" "cljs-test-runner.main" "-d" "test-sci" "-d" "test"]}
:test-cherry {:extra-paths ["test-cherry"]
:main-opts ["-m" "cljs-test-runner.main" "-d" "test-cherry" "-d" "test"]}
:test-doc-blocks {:replace-deps {org.clojure/clojure {:mvn/version "1.12.3"}
com.github.lread/test-doc-blocks {:mvn/version "1.2.21"}}
;; for -X syntax support specify exec-fn
:exec-fn lread.test-doc-blocks/gen-tests
:exec-args {:docs ["README.md"
"docs/function-schemas.md"
"docs/reusable-schemas.md"
"docs/tips.md"]}
;; for -M syntax support specify main-opts
:main-opts ["-m" "lread.test-doc-blocks" "gen-tests"]}
:test-doc-test {:replace-paths ["src" "resources" "target/test-doc-blocks/test"]}
:cljs-test-runner {:extra-deps {olical/cljs-test-runner {:mvn/version "3.8.1"}
; used only to pull in its externs file needed to compile js-joda types under advanced compilation
com.widdindustries/cljs.java-time {:mvn/version "0.1.20"}}
:extra-paths ["test" "cljs-test-runner-out/gen"]
:main-opts ["-m" "cljs-test-runner.main" "-d" "test"]}
:build {:deps {io.github.clojure/tools.build {:git/tag "v0.10.10" :git/sha "deedd62"}}
:ns-default build}
:jmh {:paths ["target/uber.jar" "classes"]
:deps {jmh-clojure/jmh-clojure {:mvn/version "0.4.1"}
jmh-clojure/task {:mvn/version "0.1.1"}}
:main-opts ["-m" "jmh.main"]}
:rebel {:extra-paths ["dev"]
:extra-deps {com.bhauman/rebel-readline #_:clj-kondo/ignore {:mvn/version "RELEASE"}
org.clojure/tools.namespace #_:clj-kondo/ignore {:mvn/version "RELEASE"}}}
:shadow {:extra-paths ["app"]
:extra-deps {thheller/shadow-cljs {:mvn/version "3.2.1"}
binaryage/devtools {:mvn/version "1.0.7"}}}
:slow {:extra-deps {io.dominic/slow-namespace-clj
{:git/url "https://git.sr.ht/~severeoverfl0w/slow-namespace-clj"
:sha "f68d66d99d95f4d2bfd61f001e28a8ad7c4d3a12"}}
:main-opts ["-m" "io.dominic.slow-namespace-clj.core"]}
:outdated {:extra-deps {com.github.liquidz/antq {:mvn/version "2.11.1276"}}
:main-opts ["-m" "antq.core"]}
:jar {:extra-deps {pack/pack.alpha
{:git/url "https://github.com/juxt/pack.alpha.git"
:sha "b093f79420fef019faf62a75b888b5e10f4e8cc9"}}
:main-opts ["-m" "mach.pack.alpha.skinny" "--no-libs"
"--project-path" "malli.jar"]}
:deploy {:extra-deps {slipset/deps-deploy {:mvn/version "0.2.2"}}
:exec-fn deps-deploy.deps-deploy/deploy
:exec-args {:installer :remote
:artifact "malli.jar"}}
:install {:extra-deps {deps-deploy/deps-deploy #_:clj-kondo/ignore {:mvn/version "RELEASE"}}
:main-opts ["-m" "deps-deploy.deps-deploy" "install"
"malli.jar"]}
:graalvm {:extra-paths ["graal-test/src"]
:extra-deps {org.clojure/clojure {:mvn/version "1.12.3"}
org.babashka/sci {:mvn/version "0.10.49"}}}
:perf {:extra-paths ["perf"]
:extra-deps {criterium/criterium {:mvn/version "0.4.6"}
org.clojure/clojure {:mvn/version "1.12.3"}
com.clojure-goes-fast/clj-async-profiler {:mvn/version "1.6.2"}}
:jvm-opts ["-server"
"-Xmx4096m"
"-Dclojure.compiler.direct-linking=true"]}}}
malli/dev/user.clj
Vendored
+37
View File
@@ -0,0 +1,37 @@
(ns user
(:require
[clojure.pprint :refer [pprint]]
[clojure.test :as test]
[clojure.tools.namespace.repl :as r]
[clojure.walk :refer [macroexpand-all]]))
(r/set-refresh-dirs "src/malli" "dev" "test/malli")
(defn- run-test
([] (run-test #"^malli.*test$"))
([o]
(r/refresh)
(cond
(instance? java.util.regex.Pattern o)
(test/run-all-tests o)
(symbol? o)
(if-let [sns (namespace o)]
(do (require (symbol sns))
(test/test-vars [(resolve o)]))
(test/test-ns o)))))
(comment
;; Refresh changed namespaces
(r/refresh)
;; Run all tests
(run-test)
;; Run all transform tests
(run-test 'malli.transform-test)
;; Run a specific test case of transform tests
(run-test 'malli.transform-test/string->uuid)
)
malli/docs/cljs-instrument-development.md
Vendored
+19
View File
@@ -0,0 +1,19 @@
To work on the function instrumentation for ClojureScript clone the malli repository and:
```bash
npm i
./node_modules/.bin/shadow-cljs watch instrument
```
Open an nREPL connection from your favorite editor to the port located in `.shadow-cljs/nrepl.port`
Open a browser to `http://localhost:8000`
the port is set in the `shadow-cljs.edn` file should you wish to change it.
In your editor evaluate:
`(shadow/repl :instrument)`
The dev-time code is located in the file: `app/malli/instrument_app.cljs`.
malli/docs/clojurescript-function-instrumentation.md
Vendored
+122
View File
@@ -0,0 +1,122 @@
# ClojureScript Function Instrumentation
Function instrumentation is also supported when developing ClojureScript browser applications.
The implementation works by collecting function schemas using a ClojureScript macro which registers the function schemas
available in the application.
Instrumentation happens at runtime in a JavaScript runtime. The functions to instrument are replaced by instrumented versions.
# Dev Setup
For the best developer experience make sure you install the latest version of binaryage/devtools and use a Chromium or Firefox based browser:
https://clojars.org/binaryage/devtools
if you are using shadow-cljs just ensure this library is on the classpath.
For an application that uses React.js such as Reagent you will typically declare an entry namespace and init function in your `shadow-cljs.edn` config like so:
```clojure
{...
:modules {:app {:entries [your-app.entry-ns]
:init-fn your-app.entry-ns/init}}
...}
```
All development-time code should ideally live in a [preload](https://shadow-cljs.github.io/docs/UsersGuide.html#_preloads) namespace.
Add a preload namespace to your codebase to enable the malli instrumentation:
```clojure
(ns com.myapp.dev-preload
{:dev/always true}
(:require
your-app.entry-ns ; <---- make sure you include your entry namespace
[malli.dev.cljs :as dev]))
(dev/start!)
```
By including your entry namespace in the `:require` form the compiler will ensure that the preload namespace is compiled
after your application. This will ensure your schemas are up-to-date when `(malil.dev.cljs/start!)` is evaluated.
We also add `{:dev/always true}` metadata to the namespace so that the compiler will never cache this file.
Add this preload to your shadow-cljs config:
```clojure
{...
:modules {:app {:entries [your-app.entry-ns]
:preloads [com.myapp.dev-preload]
:init-fn your-app.entry-ns/init}}
...}
```
If you want to get clj-kondo static checking from your function schemas add the `malli.dev.cljs-kondo-preload` namespace
to the preloads vector:
```clojure
{...
:modules {:app {:entries [your-app.entry-ns]
:preloads [com.myapp.dev-preload
malli.dev.cljs-kondo-preload ;; <----
]
:init-fn your-app.entry-ns/init}}
...}
```
Now while you develop clj-kondo config will be written under the `.clj-kondo` directory to enable static type checking
on any functions that have schemas.
## Errors in the browser console
When you get a schema validation error and instrumentation is on you will see an exception in the browser devtools.
A validation error looks like this:
<img src="img/cljs-instrument/cljs-instrument-error-collapsed.png"/>
If you click the arrow that is highlighted in the above image you will see the error message:
<img src="img/cljs-instrument/cljs-instrument-error-expanded.png"/>
and if you click the arrow highlighted in this above image you will see the stracktrace:
<img src="img/cljs-instrument/cljs-instrument-stacktrace-expanded.png"/>
the instrumented function is the one with the red rectangle around it in the image above.
If you click the filename (`instrument_app.cljs` in this example) the browser devtools will open a file viewer at the problematic call-site.
# Release builds
If you follow the strategy outlined above using a `preload` to include all development-time tooling then you don't
have to make any changes to prevent that code from ending up in a release build.
One other technique you may want to use to optimize even further is to have a separate malli registry for development
and one for your release build. The dev build may include schemas that are only used for instrumenting functions or for
attaching generators to schemas which can increase bundle size significantly.
You can use a configuration like so using the `:ns-aliases` feature of shadow-cljs to switch malli registry namespaces
without needing to update your codebase:
```clojure
{:target :browser
:output-dir "resources/public/js/main"
:asset-path "js/main"
:dev {:modules {:main {:init-fn com.my-org.client.dev-entry/init}}}
:release {:modules {:main {:init-fn com.my-org.client.release-entry/init}}
:build-options {:ns-aliases
{com.my-org.client.malli-registry com.my-org.client.malli-registry-release}}}
:closure-defines {malli.registry/type "custom"}
,,,
```
This example also demonstrates how if you really need to, you can also have a completely separate entry namespace for a release.
It should be noted also that metadata declared on function vars in ClojureScript is excluded by default by the ClojureScript
compiler. The function var metadata is only included in a build if you explicitly invoke a static call to it such as:
```clojure
(meta (var com.my-org.some.ns/a-fn))
```
Unless you explicitly ask for it, function var metadata will not be included in your compiled JS, so annotating functions
with malli schemas in metadata adds no cost on your builds.
malli/docs/function-schemas.md
Vendored
+885
View File
@@ -0,0 +1,885 @@
# Function Schemas
* [Functions](#functions)
* [Predicate Schemas](#predicate-schemas)
* [Function Schemas](#function-schemas)
* [Generative Testing](#generative-testing)
* [Function Guards](#function-guards)
* [Generating Functions](#generating-functions)
* [Multi-arity Functions](#multi-arity-functions)
* [Instrumentation](#instrumentation)
* [Flat Arrow Function Schemas](#flat-arrow-function-schemas)
* [Defn Schemas](#defn-schemas)
* [Defining Function Schemas](#defining-function-schemas)
* [Function Schema Annotations](#function-schema-annotations)
* [Function Schema Metadata](#function-schema-metadata)
* [Function Inline Schemas](#function-inline-schemas)
* [Defn Instrumentation](#defn-instrumentation)
* [Defn Checking](#defn-checking)
* [Development Instrumentation](#development-instrumentation)
* [ClojureScript Support](#clojurescript-support)
* [Static Type Checking](#static-type-checking)
* [Pretty Errors](#pretty-errors)
* [Defn Schemas via metadata](#defn-schemas-via-metadata)
* [TL;DR](#tldr)
## Functions
In Clojure, functions are first-class. Here's a simple function:
```clojure
(defn plus [x y]
(+ x y))
(plus 1 2)
;; => 3
```
## Predicate Schemas
Simplest way to describe function values with malli is to use predefined predicate schemas `fn?` and `ifn?`:
```clojure
(require '[malli.core :as m])
(m/validate fn? plus)
;; => true
(m/validate ifn? plus)
;; => true
```
Note that `ifn?` also accepts many data-structures that can be used as functions:
```clojure
(m/validate ifn? :kikka)
;; => true
(m/validate ifn? {})
;; => true
```
But, neither of the predefined function predicate schemas can validate function arity, function arguments or return values. As it stands, [there is no robust way to programmatically check function arity at runtime](https://stackoverflow.com/questions/1696693/clojure-how-to-find-out-the-arity-of-function-at-runtime).
Enter, function schemas.
## Function Schemas
Function values can be described with `:=>` and `:function` schemas. They allows description of both function arguments (as [sequence schemas](https://github.com/metosin/malli#sequence-schemas)) and function return values.
Examples of function definitions:
```clojure
;; no args, no return
[:=> :cat :nil]
;; int -> int
[:=> [:cat :int] :int]
;; x:int, xs:int* -> int
[:=> [:catn
[:x :int]
[:xs [:+ :int]]] :int]
;; arg:int -> ret:int, arg > ret
(defn guard [[arg] ret]
(> arg ret))
[:=> [:cat :int] :int [:fn guard]]
;; multi-arity function
[:function
[:=> [:cat :int] :int]
[:=> [:cat :int :int [:* :int]] :int]]
```
What is that `:cat` all about in the input schemas? Wouldn't it be simpler without it? Sure, check out [Flat Arrow Function Schema](#flat-arrow-function-schemas).
Function definition for the `plus` looks like this:
```clojure
(def =>plus [:=> [:cat :int :int] :int])
```
Let's try:
```clojure
(m/validate =>plus plus)
;; => true
```
But, wait, as there was no way to know the function arity & other information at runtime, so how did the validation work? Actually, it didn't. By default. `:=>` validation just checks that it's a `fn?`, so this holds too:
```clojure
(m/validate =>plus str)
;; => true
```
Bummer.
Enter, generative testing.
### Generative Testing
Like [clojure.spec](https://clojure.org/about/spec) demonstrated, we can use [test.check](https://github.com/clojure/test.check) to check the functions at runtime. For this, there is `:malli.core/function-checker` option.
```clojure
(require '[malli.generator :as mg])
(def =>plus
(m/schema
[:=> [:cat :int :int] :int]
{::m/function-checker mg/function-checker}))
(m/validate =>plus plus)
;; => true
(m/validate =>plus str)
;; => false
```
Explanation why it is not valid:
```clojure
(m/explain =>plus str)
;{:schema [:=> [:cat :int :int] :int],
; :value #object[clojure.core$str],
; :errors ({:path [],
; :in [],
; :schema [:=> [:cat :int :int] :int],
; :value #object[clojure.core$str],
; :check {:total-nodes-visited 0,
; :depth 0,
; :pass? false,
; :result false,
; :result-data nil,
; :time-shrinking-ms 1,
; :smallest [(0 0)],
; :malli.generator/explain-output {:schema :int,
; :value "00",
; :errors ({:path []
; :in []
; :schema :int
; :value "00"})}}})}
```
Smallest failing invocation is `(str 0 0)`, which returns `"00"`, which is not an `:int`. Looks good.
But, why `mg/function-checker` is not enabled by default? The reason is that it uses generative testing, which is orders of magnitude slower than normal validation and requires an extra dependency to `test.check`, which would make `malli.core` much heavier. This would be especially bad for CLJS bundle size.
### Function Guards
`:=>` accepts optional third child, a guard schema that is used to validate a vector of function arguments and return value.
```clojure
;; function schema of arg:int -> ret:int, where arg < ret
;; with generative function checking always enabled
(def arg<ret
(m/schema
[:=>
[:cat :int]
:int
[:fn {:error/message "argument should be less than return"}
(fn [[[arg] ret]] (< arg ret))]]
{::m/function-checker mg/function-checker}))
(m/explain arg<ret (fn [x] (inc x)))
;; => nil
(m/explain arg<ret (fn [x] x))
;{:schema ...
; :value #object[user$eval19073$fn__19074],
; :errors ({:path [],
; :in [],
; :schema ...,
; :value #object[user$eval19073$fn__19074],
; :check {:total-nodes-visited 1,
; :result false,
; :result-data nil,
; :smallest [(0)],
; :time-shrinking-ms 0,
; :pass? false,
; :depth 0,
; :malli.core/result 0}},
; {:path [2],
; :in [],
; :schema [:fn
; #:error{:message "argument should be less than return"}
; (fn [[[arg] ret]] (< arg ret))],
; :value [(0) 0]})}
(require '[malli.error :as me])
(me/humanize *1)
; ["invalid function" "argument should be less than return"]
```
Identical schema using the Schema AST syntax:
```clojure
(m/from-ast
{:type :=>
:input {:type :cat
:children [{:type :int}]}
:output {:type :int}
:guard {:type :fn
:value (fn [[[arg] ret]] (< arg ret))
:properties {:error/message "argument should be less than return"}}}
{::m/function-checker mg/function-checker})
```
### Generating Functions
We can also generate function implementations based on the function schemas. The generated functions check the function arity and arguments at runtime and return generated values.
<!-- :test-doc-blocks/skip -->
```clojure
(def plus-gen (mg/generate =>plus))
(plus-gen 1)
; =throws=> :malli.core/invalid-arity {:arity 1, :arities #{{:min 2, :max 2}}, :args [1], :input [:cat :int :int], :schema [:=> [:cat :int :int] :int]}
(plus-gen 1 "2")
; =throws=> :malli.core/invalid-input {:input [:cat :int :int], :args [1 "2"], :schema [:=> [:cat :int :int] :int]}
(plus-gen 1 2)
; => -1
```
### Multi-arity Functions
Multi-arity functions can be composed with `:function`:
<!-- :test-doc-blocks/skip -->
```clojure
;; multi-arity fn with function checking always on
(def =>my-fn
(m/schema
[:function {:registry {::small-int [:int {:min -100, :max 100}]}}
[:=> [:cat ::small-int] :int]
[:=> [:cat ::small-int ::small-int [:* ::small-int]] :int]]
{::m/function-checker mg/function-checker}))
(m/validate
=>my-fn
(fn
([x] x)
([x y & z] (apply - (- x y) z))))
; => true
(m/validate
=>my-fn
(fn
([x] x)
([x y & z] (str x y z))))
; => false
(m/explain
=>my-fn
(fn
([x] x)
([x y & z] (str x y z))))
;{:schema [:function
; {:registry {::small-int [:int {:min -100, :max 100}]}}
; [:=> [:cat ::small-int] :int]
; [:=> [:cat ::small-int ::small-int [:* ::small-int]] :int]],
; :value #object[malli.core_test$eval27255$fn__27256],
; :errors ({:path [],
; :in [],
; :schema [:function
; {:registry {::small-int [:int {:min -100, :max 100}]}}
; [:=> [:cat ::small-int] :int]
; [:=> [:cat ::small-int ::small-int [:* ::small-int]] :int]],
; :value #object[malli.core_test$eval27255$fn__27256],
; :check ({:total-nodes-visited 2,
; :depth 1,
; :pass? false,
; :result false,
; :result-data nil,
; :time-shrinking-ms 0,
; :smallest [(0 0)],
; :malli.generator/explain-output {:schema :int,
; :value "00",
; :errors ({:path []
; :in []
; :schema :int
; :value "00"})}})})}
```
Generating multi-arity functions:
<!-- :test-doc-blocks/skip -->
```clojure
(def my-fn-gen (mg/generate =>my-fn))
(my-fn-gen)
; =throws=> :malli.core/invalid-arity {:arity 0, :arities #{1 :varargs}, :args nil, :input nil, :schema [:function {:registry {::small-int [:int {:min -100, :max 100}]}} [:=> [:cat ::small-int] :int] [:=> [:cat ::small-int ::small-int [:* ::small-int]] :int]]}
(my-fn-gen 1)
; => -3237
(my-fn-gen 1 2)
; => --543
(my-fn-gen 1 2 3 4)
; => -2326
```
### Instrumentation
Besides testing function schemas as values, we can also instrument functions to enable runtime validation of arguments and return values.
Simplest way to do this is to use `m/-instrument` which takes an options map and a function and returns an instrumented function. Valid options include:
| key | description |
| ----------|-------------|
| `:schema` | function schema
| `:scope` | optional set of scope definitions, defaults to `#{:input :output}`
| `:report` | optional side-effecting function of `key data -> any` to report problems, defaults to `m/-fail!`
| `:gen` | optional function of `schema -> schema -> value` to be invoked on the args to get the return value
Instrumenting a function with input & return constraints:
<!-- :test-doc-blocks/skip -->
```clojure
(def pow
(m/-instrument
{:schema [:=> [:cat :int] [:int {:max 6}]]}
(fn [x] (* x x))))
(pow 2)
; => 4
(pow "2")
; =throws=> :malli.core/invalid-input {:input [:cat :int], :args ["2"], :schema [:=> [:cat :int] [:int {:max 6}]]}
(pow 4)
; =throws=> :malli.core/invalid-output {:output [:int {:max 6}], :value 16, :args [4], :schema [:=> [:cat :int] [:int {:max 6}]]}
(pow 4 2)
; =throws=> :malli.core/invalid-arity {:arity 2, :arities #{{:min 1, :max 1}}, :args [4 2], :input [:cat :int], :schema [:=> [:cat :int] [:int {:max 6}]]}
```
Example of a multi-arity function with instrumentation scopes and custom reporting function:
```clojure
(def multi-arity-pow
(m/-instrument
{:schema [:function
[:=> [:cat :int] [:int {:max 6}]]
[:=> [:cat :int :int] [:int {:max 6}]]]
:scope #{:input :output}
:report println}
(fn
([x] (* x x))
([x y] (* x y)))))
(multi-arity-pow 4)
;; =stdout=> :malli.core/invalid-output {:output [:int {:max 6}], :value 16, :args [4], :schema [:=> [:cat :int] [:int {:max 6}]]}
;; => 16
(multi-arity-pow 5 0.1)
;; =stdout=> :malli.core/invalid-input {:input [:cat :int :int], :args [5 0.1], :schema [:=> [:cat :int :int] [:int {:max 6}]]}
;; :malli.core/invalid-output {:output [:int {:max 6}], :value 0.5, :args [5 0.1], :schema [:=> [:cat :int :int] [:int {:max 6}]]}
;; => 0.5
```
With `:gen` we can omit the function body. Here's an example to generate random values based on the return schema:
<!-- :test-doc-blocks/skip -->
```clojure
(def pow-gen
(m/-instrument
{:schema [:function
[:=> [:cat :int] [:int {:max 6}]]
[:=> [:cat :int :int] [:int {:max 6}]]]
:gen mg/generate}))
(pow-gen 10)
; => -253
(pow-gen 10 20)
; => -159
(pow-gen 10 20 30)
; =throws=> :malli.core/invalid-arity {:arity 3, :arities #{1 2}, :args (10 20 30), :input nil, :schema [:function [:=> [:cat :int] [:int {:max 6}]] [:=> [:cat :int :int] [:int {:max 6}]]]}
```
### Flat Arrow Function Schemas
Function schema `:=>` requires input arguments to be wrapped in `:cat` or `:catn`. Since `0.16.2` there is also flat arrow schema: `:->` that allows input schema to be defined as flat sequence:
```clojure
;; no args, no return
[:-> :nil]
;; int -> int
[:-> :int :int]
;; arg:int -> ret:int, arg > ret
(defn guard [[arg] ret]
(> arg ret))
[:-> {:guard guard} :int :int]
;; multi-arity function
[:function
[:-> :int :int]
[:-> :int :int [:* :int] :int]]
```
Technically `:->` is implemented as a proxy to `:=>`. To get the actual schema:
```clojure
(m/deref [:-> :int :int])
; [:=> [:cat :int] :int]
```
This can be seen also in explain results:
```clojure
(m/explain
[:-> :int :int]
(fn [x] (str x))
{::m/function-checker mg/function-checker})
;{:schema [:-> :int :int],
; :value #object[...],
; :errors ({:path [:malli.core/in],
; :in [],
; :schema [:=> [:cat :int] :int],
; :value #object[...],
; :check {:total-nodes-visited 0,
; :result false,
; :result-data nil,
; :smallest [(0)],
; :time-shrinking-ms 0,
; :pass? false,
; :depth 0,
; :malli.core/result "0"}}
; {:path [:malli.core/in 1]
; :in [], :schema :int
; :value "0"})}
```
## Defn Schemas
### Defining Function Schemas
There are three ways to add function schemas to function Vars (e.g. `defn`s):
1. Function Schema Annotation with `m/=>`
2. Function Schema Metadata via `:malli/schema`
3. Function Inline Schemas with `mx/defn`
#### Function Schema Annotations
`m/=>` macro takes the Var name and the function schema and stores the var -> schema mappings in a global registry.
```clojure
(def small-int [:int {:max 6}])
(defn plus1 [x] (inc x))
(m/=> plus1 [:=> [:cat :int] small-int])
```
The order doesn't matter, so this also works:
```clojure
(m/=> plus1 [:=> [:cat :int] small-int])
(defn plus1 [x] (inc x))
```
Listing the current accumulation of function (Var) schemas:
```clojure
(m/function-schemas)
;{user {plus1 {:schema [:=> [:cat :int] [:int {:max 6}]]
; :ns user
; :name plus1}}}
```
Without instrumentation turned on, there is no schema enforcement:
```clojure
(plus1 10)
;; => 11
```
Turning instrumentation on:
<!-- :test-doc-blocks/skip -->
```clojure
(require '[malli.instrument :as mi])
(mi/instrument!)
; =stdout=> ..instrumented #'user/plus1
(plus1 10)
; =throws=> :malli.core/invalid-output {:output [:int {:max 6}], :value 11, :args [10], :schema [:=> [:cat :int] [:int {:max 6}]]}
```
Note that vars already containing a primitive JVM function will not be instrumented.
#### Function Schema Metadata
`defn` schemas can be defined with standard Var metadata. It allows `defn` schema documentation and instrumentation without dependencies to malli itself from the functions. It's just data.
```clojure
(defn minus
"a normal clojure function, no dependencies to malli"
{:malli/schema [:=> [:cat :int] small-int]}
[x]
(dec x))
```
To collect instrumentation for the `defn`, we need to call `mi/collect!`. It reads all public vars from a given namespace and registers function schemas from `:malli/schema` metadata.
```clojure
(mi/collect!)
; => #{#'user/minus}
(m/function-schemas)
;{user {plus1 {:schema [:=> [:cat :int] [:int {:max 6}]]
; :ns user
; :name plus1},
; minus {:schema [:=> [:cat :int] [:int {:min 6}]]
; :ns user
; :name minus}}}
```
We'll also have to reinstrument the new var:
<!-- :test-doc-blocks/skip -->
```clojure
(mi/instrument!)
; =stdout=> ..instrumented #'user/plus1
; =stdout=> ..instrumented #'user/minus
(minus 6)
; =throws=> :malli.core/invalid-output {:output [:int {:min 6}], :value 5, :args [6], :schema [:=> [:cat :int] [:int {:min 6}]]}
```
All Var metadata keys with `malli` namespace are used. The list of relevant keys:
| key | description |
| ----------------|-------------|
| `:malli/schema` | function schema
| `:malli/scope` | optional set of scope definitions, defaults to `#{:input :output}`
| `:malli/report` | optional side-effecting function of `key data -> any` to report problems, defaults to `m/-fail!`
| `:malli/gen` | optional value `true` or function of `schema -> schema -> value` to be invoked on the args to get the return value
Setting `:malli/gen` to `true` while function body generation is enabled with `mi/instrument!` allows body to be generated, to return valid generated data.
#### Function Inline Schemas
Malli also supports [Plumatic Schema -style](https://github.com/plumatic/schema#beyond-type-hints) schema hints via `malli.experimental` ns:
```clojure
(require '[malli.experimental :as mx])
(mx/defn times :- :int
"x times y"
[x :- :int, y :- small-int]
(* x y))
```
Function schema is registered automatically:
```clojure
(m/function-schemas)
;{user {plus1 {:schema [:=> [:cat :int] [:int {:max 6}]]
; :ns user
; :name plus1},
; minus {:schema [:=> [:cat :int] [:int {:max 6}]]
; :ns user
; :name minus},
; times {:schema [:=> [:cat :int [:int {:max 6}]] :int]
; :ns user
; :name times}}}
```
... but not instrumented:
```clojure
(times 10 10)
;; => 100
```
You can enable instrumentation with `mi/instrument!`:
<!-- :test-doc-blocks/skip -->
```clojure
(mi/instrument!)
; =stdout=> ..instrumented #'user/plus1
; =stdout=> ..instrumented #'user/minus
; =stdout=> ..instrumented #'user/times
(times 10 10)
; =throws=> :malli.core/invalid-input {:input [:cat :int [:int {:max 6}]], :args [10 10], :schema [:=> [:cat :int [:int {:max 6}]] :int]}
```
... or by using metadata `^:malli/always`:
```clojure
(mx/defn ^:malli/always times :- :int
"x times y"
[x :- :int, y :- small-int]
(* x y))
```
<!-- :test-doc-blocks/skip -->
```clojure
user=> (times 10 5)
50
user=> (times 10 10)
Execution error (ExceptionInfo) at malli.core/-exception (core.cljc:138).
:malli.core/invalid-input
```
### Defn Instrumentation
The function (Var) registry is passive and doesn't do anything by itself. To instrument the Vars based on the registry, there is the `malli.instrument` namespace. Var instrumentation is intended for development time, but can also be used for production builds.
```clojure
(require '[malli.instrument :as mi])
```
Vars can be instrumented with `mi/instrument!` and the instrumentation can be removed with `mi/unstrument!`.
<!-- :test-doc-blocks/skip -->
```clojure
(m/=> power [:=> [:cat :int] [:int {:max 6}]])
(defn power [x] (* x x))
(power 6)
; => 36
;; instrument all registered vars
(mi/instrument!)
(power 6)
; =throws=> :malli.core/invalid-output {:output [:int {:max 6}], :value 36, :args [6], :schema [:=> [:cat :int] [:int {:max 6}]]}
(mi/unstrument!)
(power 6)
; => 36
```
Instrumentation can be configured with the same options as `m/-instrument` and with a set of `:filters` to select which Vars should be instrumented.
<!-- :test-doc-blocks/skip -->
```clojure
(mi/instrument!
{:filters [;; everything from user ns
(mi/-filter-ns 'user)
;; ... and some vars
(mi/-filter-var #{#'power})
;; all other vars with :always-validate meta
(mi/-filter-var #(-> % meta :always-validate))]
;; scope
:scope #{:input :output}
;; just print
:report println})
(power 6)
; =stdout=> :malli.core/invalid-output {:output [:int {:max 6}], :value 36, :args [6], :schema [:=> [:cat :int] [:int {:max 6}]]}
; => 36
```
### Defn Checking
We can also check the defn schemas against their function implementations using `mi/check`. It takes same options as `mi/instrument!`.
Checking all registered schemas:
```clojure
(mi/check)
;{user/plus1 {:schema [:=> [:cat :int] [:int {:max 6}]],
; :value #object[user$plus1],
; :errors ({:path [],
; :in [],
; :schema [:=> [:cat :int] [:int {:max 6}]],
; :value #object[user$plus1],
; :check {:total-nodes-visited 12,
; :depth 4,
; :pass? false,
; :result false,
; :result-data nil,
; :time-shrinking-ms 0,
; :smallest [(6)],
; :malli.generator/explain-output {:schema [:int {:max 6}],
; :value 7,
; :errors ({:path [],
; :in [],
; :schema [:int {:max 6}],
; :value 7})}}})}}
```
It reports that the `plus1` is not correct. It accepts `:int` but promises to return `[:int {:max 6}]`. Let's fix the contract by constraining the input values.
<!-- :test-doc-blocks/skip -->
```clojure
(m/=> plus1 [:=> [:cat [:int {:max 5}]] [:int {:max 6}]])
(mg/check)
; => nil
```
All good! But, it's still wrong as the actual implementation allows invalid inputs resulting in invalid outputs (e.g. `6` -> `7`). We could enable instrumentation for the function to fail on invalid inputs at runtime - or write similar range checks ourselves into the function body.
A pragmatically correct schema for `plus1` would be `[:=> [:cat :int] [:int]]`. It also checks, but would fail on `Long/MAX_VALUE` as input. Fully correct schema would be `[:=> [:cat [:int {:max (dec Long/MAX_VALUE)}] [:int]]]`. Generative testing is best effort, not a silver bullet.
We redefined `plus1` function schema and the instrumentation is now out of sync. We have to call `mi/instrument!` to re-instrument it correctly.
<!-- :test-doc-blocks/skip -->
```clojure
;; the old schema & old error
(plus1 6)
; =throws=> :malli.core/invalid-output {:output [:int {:max 6}], :value 9, :args [8], :schema [:=> [:cat :int] [:int {:max 6}]]}
(mi/instrument!)
;; the new schema & new error
(plus1 6)
; =throws=> :malli.core/invalid-input {:input [:cat [:int {:max 5}]], :args [6], :schema [:=> [:cat [:int {:max 5}]] [:int {:max 6}]]}
```
This is not good developer experience.
We can do much better.
## Development Instrumentation
For better DX, there is `malli.dev` namespace.
```clojure
(require '[malli.dev :as dev])
```
It's main entry points is `dev/start!`, taking same options as `mi/instrument!`. It runs `mi/instrument!` and `mi/collect!` (for all loaded namespaces) once and starts watching the function registry for changes. Any change that matches the filters will cause automatic re-instrumentation for the functions. `dev/stop!` removes all instrumentation and stops watching the registry.
<!-- :test-doc-blocks/skip -->
```clojure
(defn plus1 [x] (inc x))
(m/=> plus1 [:=> [:cat :int] [:int {:max 6}]])
(dev/start!)
; malli: instrumented 1 function var
; malli: dev-mode started
(plus1 "6")
; =throws=> :malli.core/invalid-input {:input [:cat :int], :args ["6"], :schema [:=> [:cat :int] [:int {:max 6}]]}
(plus1 6)
; =throws=> :malli.core/invalid-output {:output [:int {:max 6}], :value 9, :args [8], :schema [:=> [:cat :int] [:int {:max 6}]]}
(m/=> plus1 [:=> [:cat :int] :int])
; =stdout=> ..instrumented #'user/plus1
(plus 6)
; => 7
(dev/stop!)
; malli: unstrumented 1 function vars
; malli: dev-mode stopped
```
## ClojureScript support
See the document: [docs/clojurescript-function-instrumentation.md](clojurescript-function-instrumentation.md)
### Static Type Checking
Running `malli.dev` instrumentation also emits [clj-kondo](https://github.com/metosin/malli#clj-kondo) type configs for all `defn`s, enabling basic static type checking/linting for the instrumented functions.
Here's the above code in [Cursive IDE](https://cursive-ide.com/) with [clj-kondo](https://github.com/clj-kondo/clj-kondo) enabled:
<img src="img/clj-kondo-instrumentation.png">
### Pretty Errors
For prettier runtime error messages, we can swap the default error printer / thrower.
```clojure
(require '[malli.dev.pretty :as pretty])
```
<!-- :test-doc-blocks/skip -->
```clojure
(defn plus1 [x] (inc x))
(m/=> plus1 [:=> [:cat :int] [:int {:max 6}]])
(dev/start! {:report (pretty/reporter)})
(plus1 "2")
; =stdout=>
; -- Schema Error ----------------------------------- malli.demo:13 --
;
; Invalid function arguments:
;
; ["2"]
;
; Input Schema:
;
; [:cat :int]
;
; Errors:
;
; {:in [0],
; :message "should be an integer",
; :path [0],
; :schema :int,
; :type nil,
; :value "2"}
;
; More information:
;
; https://cljdoc.org/d/metosin/malli/LATEST/doc/function-schemas
;
; --------------------------------------------------------------------
; =throws=> Execution error (ClassCastException) at malli.demo/plus1 (demo.cljc:13).
; java.lang.String cannot be cast to java.lang.Number
```
To throw the prettified error instead of just printint it:
```clojure
(dev/start! {:report (pretty/thrower)})
```
Pretty printer uses [fipp](https://github.com/brandonbloom/fipp) under the hood and has lot of configuration options:
```clojure
(dev/start! {:report (pretty/reporter (pretty/-printer {:width 80
:print-length 30
:print-level 2
:print-meta true}))})
```
### TL;DR
Example of annotating function with var meta-data and using `malli.dev` for dev-time function instrumentation, pretty runtime exceptions and clj-kondo for static checking:
<!-- :test-doc-blocks/skip -->
```clojure
(ns malli.demo)
(defn plus1
"Adds one to the number"
{:malli/schema [:=> [:cat :int] :int]}
[x] (inc x))
;; instrument, clj-kondo + pretty errors
(require '[malli.dev :as dev])
(require '[malli.dev.pretty :as pretty])
(dev/start! {:report (pretty/reporter)})
(plus1 "123")
(comment
(dev/stop!))
```
Here's the same code in [Cursive IDE](https://cursive-ide.com/) with [clj-kondo](https://github.com/clj-kondo/clj-kondo) enabled:
<img src="img/defn-schema.png"/>
## Future work
* [support Schema defn syntax](https://github.com/metosin/malli/issues/125)
* better integration with [clj-kondo](https://github.com/clj-kondo/clj-kondo) and [clojure-lsp](https://github.com/clojure-lsp/clojure-lsp) for enhanced DX.
malli/docs/img/bats-in-the-attic.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 206 KiB

malli/docs/img/clj-kondo-instrumentation.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 128 KiB

malli/docs/img/clj-kondo.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 190 KiB

malli/docs/img/cljs-instrument/cljs-instrument-error-collapsed.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 88 KiB

malli/docs/img/cljs-instrument/cljs-instrument-error-expanded.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 52 KiB

malli/docs/img/cljs-instrument/cljs-instrument-stacktrace-expanded.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 78 KiB

malli/docs/img/defn-schema.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 312 KiB

malli/docs/img/dot.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 47 KiB

malli/docs/img/malli-defn.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 376 KiB

malli/docs/img/malli-error.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

malli/docs/img/malli.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 257 KiB

malli/docs/img/plantuml.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 29 KiB

malli/docs/img/pretty-coerce.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 253 KiB

malli/docs/img/pretty-explain.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 330 KiB

malli/docs/img/var-deserialization-error.png
Vendored
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 220 KiB

malli/docs/jmh.md
Vendored
+15
View File
@@ -0,0 +1,15 @@
# Benchmarking with JMH
## Build
Requires tools build
```sh
clj -T:build all
```
## Run
```sh
clojure -M:jmh '{:output "jmh-report.edn"}'
```
malli/docs/releasing.md
Vendored
+22
View File
@@ -0,0 +1,22 @@
# Making a Malli release
1. Make sure `CHANGELOG.md` mentions all relevant unreleased changes
2. Recommended: update dependencies `clj -M:outdated --upgrade`
* Gotchas:
* The script tries to upgrade :clojure-11 alias as well. This
should not be done, as it is used to test the compatibility with
clojure 11
* If shadow-cljs is updgraded, remember to update package.json as well
* Make a PR out of this to get the CI to run all the tests!
3. Pick a new version number. Remember: we use [BreakVer](https://www.taoensso.com/break-versioning)
4. Set the version number
* Add a title to `CHANGELOG.md`
* Change the `<version>` and `<tag>` fields in `pom.xml`
5. Push to `master`
6. Create a release via the [GitHub UI](https://github.com/metosin/malli/releases/new)
* Use the version number as the tag name, eg. `0.22.33`
* Copypaste the changelog from `CHANGELOG.md` to the text field
7. Once the release is published, the `release` GitHub Action will build a release and deploy it to Clojars.
* See progress here: https://github.com/metosin/malli/actions/workflows/release.yml
8. Check that the release is listed on clojars: https://clojars.org/metosin/malli
9. Navigate to the cljdoc of the new release to trigger cljdoc build: https://cljdoc.org/versions/metosin/malli
malli/docs/reusable-schemas.md
Vendored
+228
View File
@@ -0,0 +1,228 @@
# Reusable Schemas
Malli currently has two ways for re-using schemas (instances):
1. Schemas as Vars - *the [plumatic](https://github.com/plumatic/schema) way*
2. Schemas via Global Registry - *the [spec](https://clojure.org/about/spec) way*
3. Schemas via Local Registries
## Schemas as Vars
We can define Schemas using `def`:
```clojure
(require '[malli.core :as m])
(def UserId :uuid)
(def Address
[:map
[:street :string]
[:lonlat [:tuple :double :double]]])
(def User
[:map
[:id UserId]
[:name :string]
[:address Address]])
(def user
{:id (random-uuid)
:name "Tiina"
:address {:street "Satakunnunkatu 10"
:lonlat [61.5014816, 23.7678986]}})
(m/validate User user)
;; => true
```
All subschemas as inlined as values:
```clojure
(m/schema User)
;[:map
; [:id :uuid]
; [:name :string]
; [:address [:map
; [:street :string]
; [:lonlat [:tuple :double :double]]]]]
```
## Schemas via Global Registry
To support spec-like mutable registry, we'll define the registry and a helper function to register a schema:
```clojure
(require '[malli.registry :as mr])
(defonce *registry (atom {}))
(defn register! [type ?schema]
(swap! *registry assoc type ?schema))
(mr/set-default-registry!
(mr/composite-registry
(m/default-schemas)
(mr/mutable-registry *registry)))
```
Registering Schemas:
```clojure
(register! ::user-id :uuid)
(register! ::address [:map
[:street :string]
[:lonlat [:tuple :double :double]]])
(register! ::user [:map
[:id ::user-id]
[:name :string]
[:address ::address]])
(m/validate ::user user)
;; => true
```
By default, reference keys are used instead of values:
```clojure
(m/schema ::user)
; :user/user
```
We can recursively deref the Schema to get the values:
```clojure
(m/deref-recursive ::user)
;[:map
; [:id :uuid]
; [:name :string]
; [:address [:map
; [:street :string]
; [:lonlat [:tuple :double :double]]]]]
```
### Decomplect Maps, Keys and Values
Clojure Spec declared [map specs should be of keysets only](https://clojure.org/about/spec#_map_specs_should_be_of_keysets_only). Malli supports this too:
```clojure
;; (╯°□°)╯︵ ┻━┻
(reset! *registry {})
(register! ::street :string)
(register! ::latlon [:tuple :double :double])
(register! ::address [:map ::street ::latlon])
(register! ::id :uuid)
(register! ::name :string)
(register! ::user [:map ::id ::name ::address])
(m/deref-recursive ::user)
;[:map
; [:user/id :uuid]
; [:user/name :string]
; [:user/address [:map
; [:user/street :string]
; [:user/latlon [:tuple :double :double]]]]]
;; data has a different shape now
(m/validate ::user {::id (random-uuid)
::name "Maija"
::address {::street "Kuninkaankatu 13"
::latlon [61.5014816, 23.7678986]}})
;; => true
```
## Schemas via Local Registries
Schemas can be defined as a `ref->?schema` map:
```clojure
(def registry
{::user-id :uuid
::address [:map
[:street :string]
[:lonlat [:tuple :double :double]]]
::user [:map
[:id ::user-id]
[:name :string]
[:address ::address]]})
```
Using registry via Schema properties:
```clojure
(m/schema [:schema {:registry registry} ::user])
; => :user/user
```
Using registry via options:
```clojure
(m/schema ::user {:registry (merge (m/default-schemas) registry)})
```
Works with both:
<!-- :test-doc-blocks/skip -->
```clojure
(m/deref-recursive *1)
;[:map
; [:id :uuid]
; [:name :string]
; [:address [:map
; [:street :string]
; [:lonlat [:tuple :double :double]]]]]
```
# Which one should I use?
Here's a comparison matrix of the two different ways:
| Feature | Vars | Global Registry | Local Registry |
|----------------------------------|:----:|:---------------:|:--------------:|
| Supported by Malli | ✅ | ✅ | ✅ |
| Explicit require of Schemas | ✅ | ❌ | ✅ |
| Support Recursive Schemas | ✅ | ✅ | ✅ |
| Decomplect Maps, Keys and Values | ❌ | ✅ | ✅ |
You should pick the way what works best for your project.
[My](https://gist.github.com/ikitommi) personal preference is the Var-style - it's simple and Plumatic proved it works well even with large codebases.
# Future Work
1. Could we also decomplect the Maps, Keys and Values with the Var Style?
2. Utilities for transforming between inlined and referenced models (why? why not!)
<!-- :test-doc-blocks/skip -->
```clojure
(-flatten-refs
[:schema {:registry {::user-id :uuid
::address [:map
[:street :string]
[:lonlat [:tuple :double :double]]]
::user [:map
[:id ::user-id]
[:name :string]
[:address ::address]]}}
::user])
;[:map {:id :user/user}
; [:id [:uuid {:id :user/user-id}]]
; [:name :string]
; [:address [:map {:id :user/address}
; [:street :string]
; [:lonlat [:tuple :double :double]]]]]
(-unflatten-refs *1)
;[:schema {:registry {::user-id :uuid
; ::address [:map
; [:street :string]
; [:lonlat [:tuple :double :double]]]
; ::user [:map
; [:id ::user-id]
; [:name :string]
; [:address ::address]]}}
; ::user]
```
malli/docs/tips.md
Vendored
+549
View File
@@ -0,0 +1,549 @@
# Tips
## Accessing both schema and value in transformation
```clojure
(require '[malli.core :as m])
(require '[malli.transform :as mt])
(def Address
[:map
[:id :string]
[:tags [:set :keyword]]
[:address [:map
[:street :string]
[:city :string]]]])
(def lillan
{:id "Lillan"
:tags #{:artesan :coffee :hotel}
:address {:street "Ahlmanintie 29"
:city "Tampere"}})
(m/decode
Address
lillan
(mt/transformer
{:default-decoder
{:compile (fn [schema _]
(fn [value]
(prn [value (m/form schema)])
value))}}))
;[{:id "Lillan", :tags #{:coffee :artesan :hotel}, :address {:street "Ahlmanintie 29", :city "Tampere"}} [:map [:id :string] [:tags [:set :keyword]] [:address [:map [:street :string] [:city :string]]]]]
;["Lillan" [:malli.core/val :string]]
;["Lillan" :string]
;[#{:coffee :artesan :hotel} [:malli.core/val [:set :keyword]]]
;[#{:coffee :artesan :hotel} [:set :keyword]]
;[:coffee :keyword]
;[:artesan :keyword]
;[:hotel :keyword]
;[{:street "Ahlmanintie 29", :city "Tampere"} [:malli.core/val [:map [:street :string] [:city :string]]]]
;[{:street "Ahlmanintie 29", :city "Tampere"} [:map [:street :string] [:city :string]]]
;["Ahlmanintie 29" [:malli.core/val :string]]
;["Ahlmanintie 29" :string]
;["Tampere" [:malli.core/val :string]]
;["Tampere" :string]
;; => {:id "Lillan", :tags #{:coffee :artesan :hotel}, :address {:street "Ahlmanintie 29", :city "Tampere"}}
```
## Removing Schemas based on a property
Schemas can be walked over recursively using `m/walk`:
```clojure
(require '[malli.core :as m])
(def Schema
[:map
[:user :map]
[:profile :map]
[:tags [:vector [:int {:deleteMe true}]]]
[:nested [:map [:x [:tuple {:deleteMe true} :string :string]]]]
[:token [:string {:deleteMe true}]]])
(m/walk
Schema
(fn [schema _ children options]
;; return nil if Schema has the property
(when-not (:deleteMe (m/properties schema))
;; there are two syntaxes: normal and the entry, handle separately
(let [children (if (m/entries schema) (filterv last children) children)]
;; create a new Schema with the updated children, or return nil
(try (m/into-schema (m/type schema) (m/properties schema) children options)
(catch #?(:clj Exception, :cljs js/Error) _))))))
;[:map
; [:user :map]
; [:profile :map]
; [:nested :map]]
```
In the example, `:tags` key was removed as it's contents would have been an empty `:vector`, which is not legal Schema syntax. Empty `:map` is ok.
## Trimming strings
Example how to trim all `:string` values using a custom transformer:
```clojure
(require '[malli.transform :as mt])
(require '[malli.core :as m])
(require '[clojure.string :as str])
;; a decoding transformer, only mounting to :string schemas with truthy :string/trim property
(defn string-trimmer []
(mt/transformer
{:decoders
{:string
{:compile (fn [schema _]
(let [{:string/keys [trim]} (m/properties schema)]
(when trim #(cond-> % (string? %) str/trim))))}}}))
;; trim me please
(m/decode [:string {:string/trim true, :min 1}] " kikka " string-trimmer)
;; => "kikka"
;; no trimming
(m/decode [:string {:min 1}] " " string-trimmer)
;; => " "
;; without :string/trim, decoding is a no-op
(m/decoder :string string-trimmer)
; => #object[clojure.core$identity]
```
## Decoding collections
Transforming a comma-separated string into a vector of ints:
```clojure
(require '[malli.core :as m])
(require '[malli.transform :as mt])
(require '[clojure.string :as str])
(m/decode
[:vector {:decode/string #(str/split % #",")} int?]
"1,2,3,4"
(mt/string-transformer))
;; => [1 2 3 4]
```
Using a custom transformer:
```clojure
(defn query-decoder [schema]
(m/decoder
schema
(mt/transformer
(mt/transformer
{:name "vectorize strings"
:decoders
{:vector
{:compile (fn [schema _]
(let [separator (-> schema m/properties :query/separator (or ","))]
(fn [x]
(cond
(not (string? x)) x
(str/includes? x separator) (into [] (.split ^String x separator))
:else [x]))))}}})
(mt/string-transformer))))
(def decode
(query-decoder
[:map
[:a [:vector {:query/separator ";"} :int]]
[:b [:vector :int]]]))
(decode {:a "1", :b "1"})
;; => {:a [1], :b [1]}
(decode {:a "1;2", :b "1,2"})
;; => {:a [1 2], :b [1 2]}
```
## Normalizing properties
Returning a Schema form with `nil` in place of empty properties:
```clojure
(require '[malli.core :as m])
(defn normalize-properties [?schema]
(m/walk
?schema
(fn [schema _ children _]
(if (vector? (m/form schema))
(into [(m/type schema) (m/properties schema)] children)
(m/form schema)))))
(normalize-properties
[:map
[:x :int]
[:y [:tuple :int :int]]
[:z [:set [:map [:x [:enum 1 2 3]]]]]])
;; => [:map nil
;; [:x nil :int]
;; [:y nil [:tuple nil :int :int]]
;; [:z nil [:set nil
;; [:map nil
;; [:x nil [:enum nil 1 2 3]]]]]]
```
## Default value from a function
The `mt/default-value-transformer` can fill default values if the `:default` property is given. It
is possible though to calculate a default value with a given function providing custom transformer
derived from `mt/default-value-transformer`:
```clojure
(defn default-fn-value-transformer
([]
(default-fn-value-transformer nil))
([{:keys [key] :or {key :default-fn}}]
(let [add-defaults
{:compile
(fn [schema _]
(let [->k-default (fn [[k {default key :keys [optional]} v]]
(when-not optional
(when-some [default (or default (some-> v m/properties key))]
[k default])))
defaults (into {} (keep ->k-default) (m/children schema))
exercise (fn [x defaults]
(reduce-kv (fn [acc k v]
; the key difference compare to default-value-transformer
; we evaluate v instead of just passing it
(if-not (contains? x k)
(-> (assoc acc k ((m/eval v) x))
(try (catch Exception _ acc)))
acc))
x defaults))]
(when (seq defaults)
(fn [x] (if (map? x) (exercise x defaults) x)))))}]
(mt/transformer
{:decoders {:map add-defaults}
:encoders {:map add-defaults}}))))
```
Example 1: if `:secondary` is missing, same its value to value of `:primary`
```clojure
(m/decode
[:map
[:primary :string]
[:secondary {:default-fn '#(:primary %)} :string]]
{:primary "blue"}
(default-fn-value-transformer))
```
Example 2: if `:cost` is missing, try to calculate it from `:price` and `:qty`:
```clojure
(def Purchase
[:map
[:qty {:default 1} number?]
[:price {:optional true} number?]
[:cost {:default-fn '(fn [m] (* (:qty m) (:price m)))} number?]])
(def decode-autonomous-vals
(m/decoder Purchase (mt/transformer (mt/string-transformer) (mt/default-value-transformer))))
(def decode-interconnected-vals
(m/decoder Purchase (default-fn-value-transformer)))
(-> {:qty "100" :price "1.2"} decode-autonomous-vals decode-interconnected-vals)
;; => {:price 1.2, :qty 100.0, :cost 120.0}
(-> {:price "1.2"} decode-autonomous-vals decode-interconnected-vals)
;; => {:qty 1, :price 1.2, :cost 1.2}
(-> {:prie "1.2"} decode-autonomous-vals decode-interconnected-vals)
;; => {:prie "1.2", :qty 1}
```
## Walking Schema and Entry Properties
1. walk entries on the way in
2. unwalk entries on the way out
```clojure
(defn walk-properties [schema f]
(m/walk
schema
(fn [s _ c _]
(m/into-schema
(m/-parent s)
(f (m/-properties s))
(cond->> c (m/entries s) (map (fn [[k p s]] [k (f p) (first (m/children s))])))
(m/options s)))
{::m/walk-entry-vals true}))
```
Stripping all swagger-keys:
```clojure
(defn remove-swagger-keys [p]
(not-empty
(reduce-kv
(fn [acc k _]
(cond-> acc (some #{:swagger} [k (-> k namespace keyword)]) (dissoc k)))
p p)))
(walk-properties
[:map {:title "Organisation name"}
[:ref {:swagger/description "Reference to the organisation"
:swagger/example "Acme floor polish, Houston TX"} :string]
[:kikka [:string {:swagger {:title "kukka"}}]]]
remove-swagger-keys)
;[:map {:title "Organisation name"}
; [:ref :string]
; [:kikka :string]]
```
## Allowing invalid values on optional keys
e.g. don't fail if the optional keys hava invalid values.
1. create a helper function that transforms the schema swapping the actual schema with `:any`
2. done.
```clojure
(require '[malli.util :as mu])
(defn allow-invalid-optional-values [schema]
(m/walk
schema
(m/schema-walker
(fn [s]
(cond-> s
(m/entries s)
(mu/transform-entries
(partial map (fn [[k {:keys [optional] :as p} s]] [k p (if optional :any s)]))))))))
(allow-invalid-optional-values
[:map
[:a :string]
[:b {:optional true} :int]
[:c [:maybe
[:map
[:d :string]
[:e {:optional true} :int]]]]])
;[:map
; [:a :string]
; [:b {:optional true} :any]
; [:c [:maybe [:map
; [:d :string]
; [:e {:optional true} :any]]]]]
(m/validate
[:map
[:a :string]
[:b {:optional true} :int]]
{:a "Hey" :b "Nope"})
;; => false
(m/validate
(allow-invalid-optional-values
[:map
[:a :string]
[:b {:optional true} :int]])
{:a "Hey" :b "Nope"})
;; => true
```
## Collecting inlined reference definitions from schemas
By default, one can inline schema reference definitions with `:map`, like:
```clojure
(def User
[:map
[::id :int]
[:name :string]
[::country {:optional true} :string]])
```
It would be nice to be able to simplify the schemas into:
```clojure
[:map
::id
[:name :string]
[::country {:optional true}]]
```
Use cases:
* Simplify large schemas
* Finding differences in semantics
* Refactoring multiple schemas to use a shared registry
Naive implementation (doesn't look up the local registries):
```clojure
(require '[malli.registry :as mr])
(defn collect-references [schema]
(let [acc* (atom {})
->registry (fn [registry]
(->> (for [[k d] registry]
(if (seq (rest d))
(m/-fail! ::ambiguous-references {:data d})
[k (first (keys d))]))
(into {})))
schema (m/walk
schema
(fn [schema path children _]
(let [children (if (= :map (m/type schema)) ;; just maps
(->> children
(mapv (fn [[k p s]]
;; we found inlined references
(if (and (m/-reference? k) (not (m/-reference? s)))
(do (swap! acc* update-in [k (m/form s)] (fnil conj #{}) (conj path k))
(if (seq p) [k p] k))
[k p s]))))
children)
;; accumulated registry, fail on ambiguous refs
registry (->registry @acc*)]
;; return simplified schema
(m/into-schema
(m/-parent schema)
(m/-properties schema)
children
{:registry (mr/composite-registry (m/-registry (m/options schema)) registry)}))))]
{:registry (->registry @acc*)
:schema schema}))
```
In action:
```clojure
(collect-references User)
;{:registry {:user/id :int,
; :user/country :string}
; :schema [:map
; :user/id
; [:name :string]
; [:user/country {:optional true}]]}
```
<!-- :test-doc-blocks/skip -->
```clojure
(collect-references
[:map
[:user/id :int]
[:child [:map
[:user/id :string]]]])
; =throws=> :user/ambiguous-references {:data {:string #{[:child :user/id]}, :int #{[:user/id]}}}
```
## Getting error-values into humanized result
```clojure
(require '[malli.error :as me])
(-> [:map
[:x :int]
[:y [:set :keyword]]
[:z [:map
[:a [:tuple :int :int]]]]]
(m/explain {:x "1"
:y #{:a "b" :c}
:z {:a [1 "2"]}})
(me/humanize {:wrap #(select-keys % [:value :message])}))
;; => {:x [{:value "1"
; :message "should be an integer"}],
; :y #{[{:value "b"
; :message "should be a keyword"}]},
; :z {:a [nil [{:value "2"
; :message "should be an integer"}]]}}
```
## Dependent String Schemas
A schema for a string made of two components `a` and `b` separated by a `/` where the schema of `b`
depends on the value of `a`. The valid values of a are known in advance.
For instance:
* When `a` is "ip" , `b` should be a valid ip
* When `a` is "domain", `b` should be a valid domain
Here are a few examples of valid and invalid data:
* `"ip/127.0.0.1"` is valid
* `"ip/111"` is not valid
* `"domain/cnn.com"` is valid
* `"domain/aa"` is not valid
* `"kika/aaa"` is not valid
```clojure
(def domain #"[a-zA-Z0-9][-a-zA-Z0-9]{0,62}(\.[a-zA-Z0-9][-a-zA-Z0-9]{0,62})+")
(def ipv4 #"^(?:[0-9]{1,3}\.){3}[0-9]{1,3}$")
;; a multi schema describing the values as a tuple
;; includes transformation guide to and from a string domain
(def schema [:multi {:dispatch first
:decode/string #(str/split % #"/")
:encode/string #(str/join "/" %)}
["domain" [:tuple [:= "domain"] domain]]
["ip" [:tuple [:= "ip"] ipv4]]])
;; define workers
(def validate (m/validator schema))
(def decode (m/decoder schema mt/string-transformer))
(def encode (m/encoder schema mt/string-transformer))
(decode "ip/127.0.0.1")
;; => ["ip" "127.0.0.1"]
(-> "ip/127.0.0.1" (decode) (encode))
;; => "ip/127.0.0.1"
(map (comp validate decode)
["ip/127.0.0.1"
"ip/111"
"domain/cnn.com"
"domain/aa"
"kika/aaa"])
;; => (true false true false false)
```
It is also possible to use a custom transformer instead of `string-transformer` (for example, in order to avoid `string-transformer` to perform additional encoding and decoding):
```clojure
(def schema [:multi {:dispatch first
:decode/my-custom #(str/split % #"/")
:encode/my-custom #(str/join "/" %)}
["domain" [:tuple [:= "domain"] domain]]
["ip" [:tuple [:= "ip"] ipv4]]])
(def decode (m/decoder schema (mt/transformer {:name :my-custom})))
(decode "ip/127.0.0.1")
;; => ["ip" "127.0.0.1"]
```
## Converting Schemas
Example utility to convert schemas recursively:
```clojure
(defn schema-mapper [m]
(fn [s] ((or (get m (m/type s)) ;; type mapping
(get m ::default) ;; default mapping
(constantly s)) ;; nop
s)))
(m/walk
[:map
[:id :keyword]
[:size :int]
[:tags [:set :keyword]]
[:sub
[:map
[:kw :keyword]
[:data [:tuple :keyword :int :keyword]]]]]
(m/schema-walker
(schema-mapper
{:keyword (constantly :string) ;; :keyword -> :string
:int #(m/-set-properties % {:gen/elements [1 2]}) ;; custom :int generator
::default #(m/-set-properties % {::type (m/type %)})}))) ;; for others
;[:map {::type :map}
; [:id :string]
; [:size [:int {:gen/elements [1 2 3]}]]
; [:tags [:set {::type :set} :string]]
; [:sub [:map {::type :map}
; [:kw :string]
; [:data [:tuple {::type :tuple}
; :string
; [:int {:gen/elements [1 2 3]}]
; :string]]]]]
```
malli/docs/value-transformation.md
Vendored
+15
View File
@@ -0,0 +1,15 @@
# Value Transformation
## Terminology
| Term | Description
|-------------------------|------------
| transformation function | a function of A->B, e.g. conversion strings to dates
| decoding | a process of transforming (invalid) values into potentially valid ones (IN), `m/decoder` & `m/decode`
| encoding | a process of transforming (valid) values into something else (OUT), `m/encoder` & `m/encode`
| transformer | a top-level component that maps Schemas with transformation functions (e.g. “json-transformer transforms strings to dates, but not strings to numbers”). Needed in encoding and decoding, `mt/transformer`
| named transformer | If a transformer has `:name` defined, Schemas can define their transformation functions (for both encoding & decoding) using Schema properties
| interceptor | a component that bundles transforming functions into *transforming phases*
| transforming phase | either `:enter` or `:leave`, timing when a transformation function is applied in the chain (before or after the fact)
| interceptor chain | a sequence of interceptors that is used to run the (optimized sequence of) transformation functions from interceptors in correct order
| transformation chain | transformers compose too: `(mt/transformer {:name :before} mt/json-transformer {:name :after})`
malli/graal-test/src/malli/graalvm/demo.clj
Vendored
+24
View File
@@ -0,0 +1,24 @@
(ns malli.graalvm.demo
(:gen-class)
(:require [malli.core :as m]
[malli.edn :as edn]
[malli.error :as me]
[malli.transform :as mt]))
(defn -main [& [?schema ?value]]
(println " ?schema:" (pr-str ?schema))
(println " ?value:" (pr-str ?value))
(let [schema (edn/read-string ?schema)
value (edn/-parse-string ?value)
_ (println " schema:" (pr-str schema))
_ (println " value:" (pr-str value))
decoded (m/decode schema value (mt/string-transformer))
valid (m/validate schema decoded)]
(println " decoded:" (pr-str decoded))
(println " valid:" (m/validate schema decoded))
(when-not valid
(let [explain (m/explain schema decoded)]
(println)
(println " explain:" (pr-str explain))
(println)
(println "humanized:" (pr-str (me/humanize explain)))))))
malli/graal-test/src/malli/graalvm/demosci.clj
Vendored
+25
View File
@@ -0,0 +1,25 @@
(ns malli.graalvm.demosci
(:gen-class)
(:require [sci.core]
[malli.core :as m]
[malli.edn :as edn]
[malli.error :as me]
[malli.transform :as mt]))
(defn -main [& [?schema ?value]]
(println " ?schema:" (pr-str ?schema))
(println " ?value:" (pr-str ?value))
(let [schema (edn/read-string ?schema)
value (edn/-parse-string ?value)
_ (println " schema:" (pr-str schema))
_ (println " value:" (pr-str value))
decoded (m/decode schema value (mt/string-transformer))
valid (m/validate schema decoded)]
(println " decoded:" (pr-str decoded))
(println " valid:" (m/validate schema decoded))
(when-not valid
(let [explain (m/explain schema decoded)]
(println)
(println " explain:" (pr-str explain))
(println)
(println "humanized:" (pr-str (me/humanize explain)))))))
malli/jmh.edn
Vendored
+5
View File
@@ -0,0 +1,5 @@
{:benchmarks
[{:group :schema-constructor :name :schema :fn malli.core/schema :args [:param/types]}]
:states {}
:params {:types [:int]}
:selectors {}}
malli/package-lock.json
Generated Vendored
+354
View File
@@ -0,0 +1,354 @@
{
"name": "malli",
"lockfileVersion": 2,
"requires": true,
"packages": {
"": {
"devDependencies": {
"@js-joda/core": "^5.6.5",
"@js-joda/timezone": "^2.22.0",
"isomorphic-ws": "^5.0.0",
"shadow-cljs": "^3.2.1",
"ws": "^8.18.3"
}
},
"node_modules/@js-joda/core": {
"version": "5.6.5",
"resolved": "https://registry.npmjs.org/@js-joda/core/-/core-5.6.5.tgz",
"integrity": "sha512-3zwefSMwHpu8iVUW8YYz227sIv6UFqO31p1Bf1ZH/Vom7CmNyUsXjDBlnNzcuhmOL1XfxZ3nvND42kR23XlbcQ==",
"dev": true,
"license": "BSD-3-Clause"
},
"node_modules/@js-joda/timezone": {
"version": "2.22.0",
"resolved": "https://registry.npmjs.org/@js-joda/timezone/-/timezone-2.22.0.tgz",
"integrity": "sha512-9UNXxEztbcofD6XvV7xPrbzB2nE/AWaHr/XfugRZgVqg2vCZOVPnD8QI7GW164EFIWMw0c97Gs6STJ5dh0J99Q==",
"dev": true,
"license": "BSD-3-Clause",
"peerDependencies": {
"@js-joda/core": ">=1.11.0"
}
},
"node_modules/base64-js": {
"version": "1.5.1",
"resolved": "https://registry.npmjs.org/base64-js/-/base64-js-1.5.1.tgz",
"integrity": "sha512-AKpaYlHn8t4SVbOHCy+b5+KKgvR4vrsD8vbvrbiQJps7fKDTkjkDry6ji0rUJjC0kzbNePLwzxq8iypo41qeWA==",
"dev": true,
"funding": [
{
"type": "github",
"url": "https://github.com/sponsors/feross"
},
{
"type": "patreon",
"url": "https://www.patreon.com/feross"
},
{
"type": "consulting",
"url": "https://feross.org/support"
}
],
"license": "MIT"
},
"node_modules/buffer": {
"version": "6.0.3",
"resolved": "https://registry.npmjs.org/buffer/-/buffer-6.0.3.tgz",
"integrity": "sha512-FTiCpNxtwiZZHEZbcbTIcZjERVICn9yq/pDFkTl95/AxzD1naBctN7YO68riM/gLSDY7sdrMby8hofADYuuqOA==",
"dev": true,
"funding": [
{
"type": "github",
"url": "https://github.com/sponsors/feross"
},
{
"type": "patreon",
"url": "https://www.patreon.com/feross"
},
{
"type": "consulting",
"url": "https://feross.org/support"
}
],
"license": "MIT",
"dependencies": {
"base64-js": "^1.3.1",
"ieee754": "^1.2.1"
}
},
"node_modules/buffer-from": {
"version": "1.1.2",
"resolved": "https://registry.npmjs.org/buffer-from/-/buffer-from-1.1.2.tgz",
"integrity": "sha512-E+XQCRwSbaaiChtv6k6Dwgc+bx+Bs6vuKJHHl5kox/BaKbhiXzqQOwK4cO22yElGp2OCmjwVhT3HmxgyPGnJfQ==",
"dev": true,
"license": "MIT"
},
"node_modules/ieee754": {
"version": "1.2.1",
"resolved": "https://registry.npmjs.org/ieee754/-/ieee754-1.2.1.tgz",
"integrity": "sha512-dcyqhDvX1C46lXZcVqCpK+FtMRQVdIMN6/Df5js2zouUsqG7I6sFxitIC+7KYK29KdXOLHdu9zL4sFnoVQnqaA==",
"dev": true,
"funding": [
{
"type": "github",
"url": "https://github.com/sponsors/feross"
},
{
"type": "patreon",
"url": "https://www.patreon.com/feross"
},
{
"type": "consulting",
"url": "https://feross.org/support"
}
],
"license": "BSD-3-Clause"
},
"node_modules/isexe": {
"version": "3.1.1",
"resolved": "https://registry.npmjs.org/isexe/-/isexe-3.1.1.tgz",
"integrity": "sha512-LpB/54B+/2J5hqQ7imZHfdU31OlgQqx7ZicVlkm9kzg9/w8GKLEcFfJl/t7DCEDueOyBAD6zCCwTO6Fzs0NoEQ==",
"dev": true,
"license": "ISC",
"engines": {
"node": ">=16"
}
},
"node_modules/isomorphic-ws": {
"version": "5.0.0",
"resolved": "https://registry.npmjs.org/isomorphic-ws/-/isomorphic-ws-5.0.0.tgz",
"integrity": "sha512-muId7Zzn9ywDsyXgTIafTry2sV3nySZeUDe6YedVd1Hvuuep5AsIlqK+XefWpYTyJG5e503F2xIuT2lcU6rCSw==",
"dev": true,
"license": "MIT",
"peerDependencies": {
"ws": "*"
}
},
"node_modules/process": {
"version": "0.11.10",
"resolved": "https://registry.npmjs.org/process/-/process-0.11.10.tgz",
"integrity": "sha512-cdGef/drWFoydD1JsMzuFf8100nZl+GT+yacc2bEced5f9Rjk4z+WtFUTBu9PhOi9j/jfmBPu0mMEY4wIdAF8A==",
"dev": true,
"license": "MIT",
"engines": {
"node": ">= 0.6.0"
}
},
"node_modules/readline-sync": {
"version": "1.4.10",
"resolved": "https://registry.npmjs.org/readline-sync/-/readline-sync-1.4.10.tgz",
"integrity": "sha512-gNva8/6UAe8QYepIQH/jQ2qn91Qj0B9sYjMBBs3QOB8F2CXcKgLxQaJRP76sWVRQt+QU+8fAkCbCvjjMFu7Ycw==",
"dev": true,
"engines": {
"node": ">= 0.8.0"
}
},
"node_modules/shadow-cljs": {
"version": "3.2.1",
"resolved": "https://registry.npmjs.org/shadow-cljs/-/shadow-cljs-3.2.1.tgz",
"integrity": "sha512-xsTSHGUBGZqotbjdKTbKUuPaYoj41ozMPbylr0aQNHvpG+TEner7YTALPdthNGUsIseE+U7kNHV9HNTfRXc/Zw==",
"dev": true,
"license": "ISC",
"dependencies": {
"buffer": "^6.0.3",
"process": "^0.11.10",
"readline-sync": "^1.4.10",
"shadow-cljs-jar": "1.3.4",
"source-map-support": "^0.5.21",
"which": "^5.0.0",
"ws": "^8.18.1"
},
"bin": {
"shadow-cljs": "cli/runner.js"
},
"engines": {
"node": ">=6.0.0"
}
},
"node_modules/shadow-cljs-jar": {
"version": "1.3.4",
"resolved": "https://registry.npmjs.org/shadow-cljs-jar/-/shadow-cljs-jar-1.3.4.tgz",
"integrity": "sha512-cZB2pzVXBnhpJ6PQdsjO+j/MksR28mv4QD/hP/2y1fsIa9Z9RutYgh3N34FZ8Ktl4puAXaIGlct+gMCJ5BmwmA==",
"dev": true
},
"node_modules/source-map": {
"version": "0.6.1",
"resolved": "https://registry.npmjs.org/source-map/-/source-map-0.6.1.tgz",
"integrity": "sha512-UjgapumWlbMhkBgzT7Ykc5YXUT46F0iKu8SGXq0bcwP5dz/h0Plj6enJqjz1Zbq2l5WaqYnrVbwWOWMyF3F47g==",
"dev": true,
"license": "BSD-3-Clause",
"engines": {
"node": ">=0.10.0"
}
},
"node_modules/source-map-support": {
"version": "0.5.21",
"resolved": "https://registry.npmjs.org/source-map-support/-/source-map-support-0.5.21.tgz",
"integrity": "sha512-uBHU3L3czsIyYXKX88fdrGovxdSCoTGDRZ6SYXtSRxLZUzHg5P/66Ht6uoUlHu9EZod+inXhKo3qQgwXUT/y1w==",
"dev": true,
"license": "MIT",
"dependencies": {
"buffer-from": "^1.0.0",
"source-map": "^0.6.0"
}
},
"node_modules/which": {
"version": "5.0.0",
"resolved": "https://registry.npmjs.org/which/-/which-5.0.0.tgz",
"integrity": "sha512-JEdGzHwwkrbWoGOlIHqQ5gtprKGOenpDHpxE9zVR1bWbOtYRyPPHMe9FaP6x61CmNaTThSkb0DAJte5jD+DmzQ==",
"dev": true,
"license": "ISC",
"dependencies": {
"isexe": "^3.1.1"
},
"bin": {
"node-which": "bin/which.js"
},
"engines": {
"node": "^18.17.0 || >=20.5.0"
}
},
"node_modules/ws": {
"version": "8.18.3",
"resolved": "https://registry.npmjs.org/ws/-/ws-8.18.3.tgz",
"integrity": "sha512-PEIGCY5tSlUt50cqyMXfCzX+oOPqN0vuGqWzbcJ2xvnkzkq46oOpz7dQaTDBdfICb4N14+GARUDw2XV2N4tvzg==",
"dev": true,
"license": "MIT",
"engines": {
"node": ">=10.0.0"
},
"peerDependencies": {
"bufferutil": "^4.0.1",
"utf-8-validate": ">=5.0.2"
},
"peerDependenciesMeta": {
"bufferutil": {
"optional": true
},
"utf-8-validate": {
"optional": true
}
}
}
},
"dependencies": {
"@js-joda/core": {
"version": "5.6.5",
"resolved": "https://registry.npmjs.org/@js-joda/core/-/core-5.6.5.tgz",
"integrity": "sha512-3zwefSMwHpu8iVUW8YYz227sIv6UFqO31p1Bf1ZH/Vom7CmNyUsXjDBlnNzcuhmOL1XfxZ3nvND42kR23XlbcQ==",
"dev": true
},
"@js-joda/timezone": {
"version": "2.22.0",
"resolved": "https://registry.npmjs.org/@js-joda/timezone/-/timezone-2.22.0.tgz",
"integrity": "sha512-9UNXxEztbcofD6XvV7xPrbzB2nE/AWaHr/XfugRZgVqg2vCZOVPnD8QI7GW164EFIWMw0c97Gs6STJ5dh0J99Q==",
"dev": true,
"requires": {}
},
"base64-js": {
"version": "1.5.1",
"resolved": "https://registry.npmjs.org/base64-js/-/base64-js-1.5.1.tgz",
"integrity": "sha512-AKpaYlHn8t4SVbOHCy+b5+KKgvR4vrsD8vbvrbiQJps7fKDTkjkDry6ji0rUJjC0kzbNePLwzxq8iypo41qeWA==",
"dev": true
},
"buffer": {
"version": "6.0.3",
"resolved": "https://registry.npmjs.org/buffer/-/buffer-6.0.3.tgz",
"integrity": "sha512-FTiCpNxtwiZZHEZbcbTIcZjERVICn9yq/pDFkTl95/AxzD1naBctN7YO68riM/gLSDY7sdrMby8hofADYuuqOA==",
"dev": true,
"requires": {
"base64-js": "^1.3.1",
"ieee754": "^1.2.1"
}
},
"buffer-from": {
"version": "1.1.2",
"resolved": "https://registry.npmjs.org/buffer-from/-/buffer-from-1.1.2.tgz",
"integrity": "sha512-E+XQCRwSbaaiChtv6k6Dwgc+bx+Bs6vuKJHHl5kox/BaKbhiXzqQOwK4cO22yElGp2OCmjwVhT3HmxgyPGnJfQ==",
"dev": true
},
"ieee754": {
"version": "1.2.1",
"resolved": "https://registry.npmjs.org/ieee754/-/ieee754-1.2.1.tgz",
"integrity": "sha512-dcyqhDvX1C46lXZcVqCpK+FtMRQVdIMN6/Df5js2zouUsqG7I6sFxitIC+7KYK29KdXOLHdu9zL4sFnoVQnqaA==",
"dev": true
},
"isexe": {
"version": "3.1.1",
"resolved": "https://registry.npmjs.org/isexe/-/isexe-3.1.1.tgz",
"integrity": "sha512-LpB/54B+/2J5hqQ7imZHfdU31OlgQqx7ZicVlkm9kzg9/w8GKLEcFfJl/t7DCEDueOyBAD6zCCwTO6Fzs0NoEQ==",
"dev": true
},
"isomorphic-ws": {
"version": "5.0.0",
"resolved": "https://registry.npmjs.org/isomorphic-ws/-/isomorphic-ws-5.0.0.tgz",
"integrity": "sha512-muId7Zzn9ywDsyXgTIafTry2sV3nySZeUDe6YedVd1Hvuuep5AsIlqK+XefWpYTyJG5e503F2xIuT2lcU6rCSw==",
"dev": true,
"requires": {}
},
"process": {
"version": "0.11.10",
"resolved": "https://registry.npmjs.org/process/-/process-0.11.10.tgz",
"integrity": "sha512-cdGef/drWFoydD1JsMzuFf8100nZl+GT+yacc2bEced5f9Rjk4z+WtFUTBu9PhOi9j/jfmBPu0mMEY4wIdAF8A==",
"dev": true
},
"readline-sync": {
"version": "1.4.10",
"resolved": "https://registry.npmjs.org/readline-sync/-/readline-sync-1.4.10.tgz",
"integrity": "sha512-gNva8/6UAe8QYepIQH/jQ2qn91Qj0B9sYjMBBs3QOB8F2CXcKgLxQaJRP76sWVRQt+QU+8fAkCbCvjjMFu7Ycw==",
"dev": true
},
"shadow-cljs": {
"version": "3.2.1",
"resolved": "https://registry.npmjs.org/shadow-cljs/-/shadow-cljs-3.2.1.tgz",
"integrity": "sha512-xsTSHGUBGZqotbjdKTbKUuPaYoj41ozMPbylr0aQNHvpG+TEner7YTALPdthNGUsIseE+U7kNHV9HNTfRXc/Zw==",
"dev": true,
"requires": {
"buffer": "^6.0.3",
"process": "^0.11.10",
"readline-sync": "^1.4.10",
"shadow-cljs-jar": "1.3.4",
"source-map-support": "^0.5.21",
"which": "^5.0.0",
"ws": "^8.18.1"
}
},
"shadow-cljs-jar": {
"version": "1.3.4",
"resolved": "https://registry.npmjs.org/shadow-cljs-jar/-/shadow-cljs-jar-1.3.4.tgz",
"integrity": "sha512-cZB2pzVXBnhpJ6PQdsjO+j/MksR28mv4QD/hP/2y1fsIa9Z9RutYgh3N34FZ8Ktl4puAXaIGlct+gMCJ5BmwmA==",
"dev": true
},
"source-map": {
"version": "0.6.1",
"resolved": "https://registry.npmjs.org/source-map/-/source-map-0.6.1.tgz",
"integrity": "sha512-UjgapumWlbMhkBgzT7Ykc5YXUT46F0iKu8SGXq0bcwP5dz/h0Plj6enJqjz1Zbq2l5WaqYnrVbwWOWMyF3F47g==",
"dev": true
},
"source-map-support": {
"version": "0.5.21",
"resolved": "https://registry.npmjs.org/source-map-support/-/source-map-support-0.5.21.tgz",
"integrity": "sha512-uBHU3L3czsIyYXKX88fdrGovxdSCoTGDRZ6SYXtSRxLZUzHg5P/66Ht6uoUlHu9EZod+inXhKo3qQgwXUT/y1w==",
"dev": true,
"requires": {
"buffer-from": "^1.0.0",
"source-map": "^0.6.0"
}
},
"which": {
"version": "5.0.0",
"resolved": "https://registry.npmjs.org/which/-/which-5.0.0.tgz",
"integrity": "sha512-JEdGzHwwkrbWoGOlIHqQ5gtprKGOenpDHpxE9zVR1bWbOtYRyPPHMe9FaP6x61CmNaTThSkb0DAJte5jD+DmzQ==",
"dev": true,
"requires": {
"isexe": "^3.1.1"
}
},
"ws": {
"version": "8.18.3",
"resolved": "https://registry.npmjs.org/ws/-/ws-8.18.3.tgz",
"integrity": "sha512-PEIGCY5tSlUt50cqyMXfCzX+oOPqN0vuGqWzbcJ2xvnkzkq46oOpz7dQaTDBdfICb4N14+GARUDw2XV2N4tvzg==",
"dev": true,
"requires": {}
}
}
}
malli/package.json
Vendored
+9
View File
@@ -0,0 +1,9 @@
{
"devDependencies": {
"@js-joda/core": "^5.6.5",
"@js-joda/timezone": "^2.22.0",
"isomorphic-ws": "^5.0.0",
"shadow-cljs": "^3.2.1",
"ws": "^8.18.3"
}
}
malli/perf/malli/perf/core.cljc
Vendored
+52
View File
@@ -0,0 +1,52 @@
(ns malli.perf.core
(:require [criterium.core :as cc]
[clj-async-profiler.core :as prof]))
(defn serve! []
(with-out-str (prof/serve-ui 8080))
nil)
(defn clear! []
(prof/clear-results))
(defmacro -bench [& body]
`(cc/quick-bench ~@body))
(defmacro profile [& body]
`(let [start# (System/currentTimeMillis)]
(dotimes [_# 10000] ~@body)
(let [ms# (- (System/currentTimeMillis) start#)
times# (int (/ 100000000 ms#))]
(println "invoking" times# "times")
(time (prof/profile (dotimes [_# times#] ~@body))))))
(defmacro bench [& body]
`(do (serve!) (-bench ~@body) (profile ~@body)))
(comment (clear!))
(defmacro profile-for
[n & body]
`(let [res# (cc/quick-benchmark (do ~@body) {})
mean# (first (:mean res#))
k# (long (/ ~n mean#))]
(println (* 1e9 mean#))
(println
(with-out-str
(cc/quick-bench ~@body)))
(println "Profiling for" ~n "seconds" k# "times")
(time
(prof/profile
(dotimes [_# k#]
~@body)))))
(defmacro bench->
[data & expr]
`(doseq [[name# data#] ~data]
(let [mean# (first (:mean (cc/quick-benchmark (-> data# ~expr) {})))
[scale# unit#] (cc/scale-time mean#)]
(println name# (* mean# scale#) unit#))))
(comment
(clear!)
(serve!))
malli/perf/malli/perf/creation_perf_test.cljc
Vendored
+266
View File
@@ -0,0 +1,266 @@
(ns malli.perf.creation-perf-test
(:require [malli.perf.core :as p]
[malli.core :as m]
[malli.generator :as mg]
[malli.util :as mu]))
(comment
;;
;; validation
;;
;; 5.2µs
;; 3.6µs
;; 3.0µs (map childs)
;; 3.2µs (mapv childs)
;; 2.5µs (...)
;; 2.3µs (-vmap, don't check children)
;; 1.1µs
(p/bench (m/validate [:or :int :string] 42))
;; 2.6µs
;; 1.3µs
(p/bench (m/validate (m/from-ast {:type :or, :children [{:type :int} {:type :string}]}) 42))
;; 15ns
(let [schema (m/schema [:or :int :string])]
(p/bench (m/validate schema 42)))
;; 3.0µs
;; 500ns (delayed mapv childs)
;; 1.7µs
;; 510ns (map childs)
;; 310ns (schema)
;; 300ns (simple-schema)
;; 180ns (fast parse)
;; 1.1µs (mapv childs)
;; 750ns (...)
;; 680ns (-vmap, don't check children)
(p/bench (m/schema [:or :int :string]))
;; 730ns
(p/bench (m/from-ast {:type :or, :children [{:type :int} {:type :string}]}))
;; 1.7µs
;; 470ns (map childs)
;; 310ns (schema)
;; 300ns (simple-schema)
;; 190ns (fast parse)
;; 1.1µs (mapv childs)
;; 750ns (...)
;; 680ns (-vmap, don't check children)
(p/bench (m/schema [:and :int :string]))
;; 730ns
(p/bench (m/from-ast {:type :and, :children [{:type :int} {:type :string}]}))
;; 1.7µs
;; 1.5µs (fast parse)
;; 540ns (non-distinct)
;; 13ns (-cache)
(let [schema (m/schema [:or :int :string])]
(p/bench (m/validator schema)))
;; 16ns
(let [schema (m/schema [:or :int :string])]
(p/bench (m/validate schema 42)))
;; 3ns
(let [validate (m/validator [:or :int :string])]
(p/bench (validate 42))))
(def ?schema
[:map
[:x boolean?]
[:y {:optional true} int?]
[:z [:map
[:x boolean?]
[:y {:optional true} int?]]]])
(def schema (m/schema ?schema))
(def ast (m/ast ?schema))
(def leaf-schema (m/schema :int))
(comment
;;
;; schema creation
;;
;; 480ns -> 400ns -> 340ns -> 280ns -> 240ns -> 170ns (registry) -> 160ns (recur)
(p/bench (m/schema :int))
;; 180ns
(p/bench (m/from-ast {:type :int}))
;; 44µs -> 31µs -> 18µs -> 11µs -> 9.4µs -> 9.0µs -> 8.5µs -> 7.0µs -> 6.4µs (registry) -> 5.7µs
;; 3.4µs
;; 2.9µs (-entry-parser)
;; 2.5µs (no entries, object-arraus)
(p/bench (m/schema ?schema))
;; 44µs -> 240ns
(p/bench (m/schema ?schema {::m/lazy-entries true}))
;; 147ns
(p/bench (m/from-ast ast))
;; 3.7µs
(p/bench (m/validator (m/schema ?schema)))
;; 2.5µs
(p/bench (m/validator (m/from-ast ast)))
;; 1.6µs -> 64ns
(p/bench (m/validate schema {:x true, :z {:x true}}))
;; 1.6µs -> 450ns
(p/bench (m/explain schema {:x true, :z {:x true}}))
;; does not work with direct linking
(with-redefs [m/-check-children? (constantly false)]
(p/bench (m/schema ?schema))))
(def ref-schema (m/schema [:schema :int]))
(comment
;; 14ns -> 5ns
(p/bench (m/deref ref-schema))
;; 5µs -> 28ns
(p/bench (m/deref-all ref-schema)))
(comment
;;
;; schema transformation
;;
;; 271ns
;; 14ns (-set-children, -set-properties)
;; 12ns (-entry-parser)
(p/bench (m/walk leaf-schema (m/schema-walker identity)))
;; 26µs
;; 1.3µs (-set-children, -set-properties)
;; 1.2µs (protocols, registry, recur)
(p/bench (m/walk schema (m/schema-walker identity)))
;; 51µs
;; 44µs (-set-children, -set-properties)
;; 29µs (lot's of stuff)
;; 21µs (faster parsing)
;; 7.5µs (ever faster parsing)
;; 7.2µs (compact parsing)
;; 6.5µs (schema)
;; 5.8µs (protocols, registry, recur, parsed)
;; 3.9µs (-parsed)
;; 3.6µs (-entry-parser)
;; 3.4µs (object-array)
(p/bench (mu/closed-schema schema))
;; 3.8µs
;; 3.4µs (satisfies?)
;; 2.2µs (-set-entries)
;; 830ns (-update-parsed)
;; 560ns (-entry-parser)
(p/bench (mu/assoc schema :y :string))
;; 4.2µs
;; 3.8µs (satisfies?)
;; 820ns (-update-parsed)
;; 540ns (-entry-parser)
(p/bench (mu/assoc schema :w :string))
;; 205ns
;; 195ns
(p/bench (mu/get schema :y))
;; 13µs
;; 2.4µs (satisfies?)
;; 1.8µs
(p/bench (mu/required-keys schema))
;; 134µs
;; 15µs (satisfies?)
;; 9µs (fast merge)
(p/bench (mu/merge schema schema)))
(comment
;; 119µs
;; 16µs (cache generator)
(p/bench (mg/generate schema)))
(comment
(let [t ::or, p {:a 1}, c (mapv m/schema [:int :int])]
;; 480ns
;; 221ns (faster impl)
(p/bench (m/-create-form t p c nil))))
(comment
(let [s (m/schema :int)]
;; 440ns
;; 341ns (-create-form)
;; 150ns (delayed form)
;; 30ns (don't -check-children)
(p/bench (m/-val-schema s nil))))
(comment
"clojurescript perf tests"
; shadow-cljs browser-repl
(require '[malli.core :as m])
(require '[malli.util :as mu])
(def ?schema
[:map
[:x boolean?]
[:y {:optional true} int?]
[:z [:map
[:x boolean?]
[:y {:optional true} int?]]]])
(def schema (m/schema ?schema))
(def ref-schema (m/schema [:schema :int]))
;;
;; benchmarks (0.6.1 vs LATEST)
;;
(simple-benchmark [] (m/schema :int) 100000)
; [], (m/schema :int), 100000 runs, 181 msecs
; [], (m/schema :int), 100000 runs, 55 msecs (3x)
(simple-benchmark [] (m/schema [:or :int :string]) 100000)
; [], (m/schema [:or :int :string]), 100000 runs, 654 msecs
; [], (m/schema [:or :int :string]), 100000 runs, 185 msecs (4x)
(simple-benchmark [] (m/schema ?schema) 10000)
; [], (m/schema ?schema), 10000 runs, 896 msecs
; [], (m/schema ?schema), 10000 runs, 156 msecs (6x)
; [], (m/schema ?schema), 10000 runs, 94 msecs (9.5x)
(simple-benchmark [] (m/walk schema (m/schema-walker identity)) 10000)
; [], (m/walk schema (m/schema-walker identity)), 10000 runs, 544 msecs
; [], (m/walk schema (m/schema-walker identity)), 10000 runs, 41 msecs (13x)
(simple-benchmark [] (mu/closed-schema schema) 10000)
; [], (mu/closed-schema schema), 10000 runs, 1046 msecs
; [], (mu/closed-schema schema), 10000 runs, 163 msecs (6x)
; [], (mu/closed-schema schema), 10000 runs, 104 msecs (10x)
(simple-benchmark [] (m/deref ref-schema) 1000000)
; [], (m/deref ref-schema), 1000000 runs, 53 msecs
; [], (m/deref ref-schema), 1000000 runs, 53 msecs
(simple-benchmark [] (m/deref-all ref-schema) 1000000)
; [], (m/deref-all ref-schema), 1000000 runs, 104 msecs
; [], (m/deref-all ref-schema), 1000000 runs, 55 msecs
)
malli/perf/malli/perf/perf_test.cljc
Vendored
+524
View File
@@ -0,0 +1,524 @@
(ns malli.perf.perf-test
(:require [clojure.spec.alpha :as s]
[malli.perf.core :as p]
[clj-async-profiler.core :as prof]
[minimallist.helper :as mh]
[minimallist.core :as mc]
[net.cgrand.seqexp :as se]
[malli.core :as m]
[spec-tools.core :as st]
[schema.core :as sc]
[schema.coerce :as scc]
[clojure.pprint]
[malli.transform :as mt]
[malli.provider :as mp]))
(s/def ::x boolean?)
(s/def ::y int?)
(s/def ::z string?)
(defn map-perf []
(let [valid {:x true, :y 1, :z "kikka"}]
;; 30ns
(let [valid? (fn [m]
(and (if-let [v (:x m)] (boolean? v) false)
(if-let [v (:y m)] (int? v) true)
(if-let [v (:z m)] (string? v) false)))]
(assert (valid? valid))
(p/bench (valid? valid)))
;; 40ns
(let [valid? (m/validator [:map
[:x boolean?]
[:y {:optional true} int?]
[:z string?]])]
(assert (valid? valid))
(p/bench (valid? valid)))
;; 450ns
(let [spec (s/keys :req-un [::x ::z] :opt-un [::y])]
(assert (s/valid? spec valid))
(p/bench (s/valid? spec valid)))
;; 650ns
(let [valid? (sc/checker {:x sc/Bool
(sc/optional-key :y) sc/Int
:z sc/Str})]
(assert (not (valid? valid)))
(p/bench (valid? valid)))))
(defn composite-perf []
;; 7ns
(let [valid? (fn [x] (and (int? x) (or (pos-int? x) (neg-int? x))))]
(assert (= [true false true] (map valid? [-1 0 1])))
(p/bench (valid? 0)))
;; 9ns
(let [valid? (m/validator [:and int? [:or pos-int? neg-int?]])]
(assert (= [true false true] (map valid? [-1 0 1])))
(p/bench (valid? 0)))
;; 60ns
(let [spec (s/and int? (s/or :pos-int pos-int? :neg-int neg-int?))]
(assert (= [true false true] (map (partial s/valid? spec) [-1 0 1])))
(p/bench (s/valid? spec 0)))
;; 130ns
(let [valid? (sc/checker (sc/both sc/Int (sc/conditional pos-int? (sc/pred pos-int?) :else (sc/pred neg-int?))))]
(assert (= [true false true] (map (comp boolean not valid?) [-1 0 1])))
(p/bench (valid? 0))))
(defn composite-perf2 []
(let [assert! (fn [f]
(doseq [[expected data] [[true [-1]]
[true [-1 1 2]]
[false [-1 0 2]]
[false [-1 -1 -1 -1]]]]
(assert (= expected (f data)))))]
;; 155ns
(let [valid? (fn [x]
(and (vector? x)
(<= (count x) 3)
(every? #(and (int? %) (or (pos-int? %) (neg-int? %))) x)))]
(assert! valid?)
(p/bench (valid? [-1 1 2])))
;; 29ns
(let [valid? (m/validator
[:vector {:max 3}
[:and int? [:or pos-int? neg-int?]]])]
(assert! valid?)
(p/bench (valid? [-1 1 2])))
;; 560ns
(let [spec (s/coll-of
(s/and int? (s/or :pos-int pos-int? :neg-int neg-int?))
:kind vector?
:max-count 3)
valid? (partial s/valid? spec)]
(assert! valid?)
(p/bench (valid? [-1 1 2])))))
(s/def ::id string?)
(s/def ::tags (s/coll-of keyword? :kind set? :into #{}))
(s/def ::street string?)
(s/def ::city string?)
(s/def ::zip int?)
(s/def ::lonlat (s/coll-of double? :min-count 2, :max-count 2))
(s/def ::address (s/keys
:req-un [::street ::city ::zip]
:opt-un [::lonlat]))
(s/def ::place (s/keys :req-un [::id ::tags ::address]))
(def Place
[:map
[:id string?]
[:tags [:set keyword?]]
[:address
[:map
[:street string?]
[:city string?]
[:zip int?]
[:lonlat [:tuple double? double?]]]]])
(defn composite-explain-perf []
(let [valid {:id "Metosin"
:tags #{:clj :cljs}
:address {:street "Hämeenkatu 14"
:city "Tampere"
:zip 33800
:lonlat [61.4983866 23.7644223]}}
invalid {:id "Metosin"
:tags #{"clj" "cljs"}
:address {:street "Hämeenkatu 14"
:zip 33800
:lonlat [61.4983866 nil]}}]
(let [explain #(s/explain-data ::place %)]
;; 5.0µs
(p/bench (explain valid))
;; 19µs
(p/bench (explain invalid)))
(let [explain (m/explainer Place)]
(assert (not (explain valid)))
(assert (explain invalid))
;; 1.2µs
(p/bench (explain valid))
;; 1.4µs
(p/bench (explain invalid)))))
(defn transform-test []
(let [json {:id "Metosin"
:tags ["clj" "cljs"]
:address {:street "Hämeenkatu 14"
:zip 33800
:lonlat [61 23.7644223]}}]
(let [json->place #(st/coerce ::place % st/json-transformer)]
(clojure.pprint/pprint (json->place json))
;; 74µs (wrong result!)
(p/bench (json->place json)))
(let [json->place (m/decoder Place mt/json-transformer)]
(clojure.pprint/pprint (json->place json))
;; 1µs -> 800ns
(p/bench (json->place json)))))
(defn transform-test2 []
;;
;; predicate coercion
;;
;; 6µs
(let [string->edn #(st/coerce int? % st/string-transformer)]
(assert (= 1
(string->edn "1")
(string->edn 1)))
(p/bench (string->edn "1")))
;; 4ns
(let [string->edn (m/decoder int? mt/string-transformer)]
(assert (= 1
(string->edn "1")
(string->edn 1)))
(p/bench (string->edn "1")))
;;
;; simple map coercion
;;
(s/def ::id int?)
(s/def ::name string?)
;; 14µs
(let [spec (s/keys :req-un [::id ::name])
string->edn #(st/coerce spec % st/string-transformer)]
(assert (= {:id 1, :name "kikka"}
(string->edn {:id 1, :name "kikka"})
(string->edn {:id "1", :name "kikka"})))
(p/bench (string->edn {:id "1", :name "kikka"})))
;; 44ns
(let [schema [:map [:id int?] [:name string?]]
string->edn (m/decoder schema mt/string-transformer)]
(assert (= {:id 1, :name "kikka"}
(string->edn {:id 1, :name "kikka"})
(string->edn {:id "1", :name "kikka"})))
(p/bench (string->edn {:id "1", :name "kikka"})))
;; 46ns
(let [string->edn (fn [x] (update x :id (fn [id] (if (string? id) (Long/parseLong id) id))))]
(assert (= {:id 1, :name "kikka"}
(string->edn {:id 1, :name "kikka"})
(string->edn {:id "1", :name "kikka"})))
(p/bench (string->edn {:id "1", :name "kikka"})))
;; 1.4µs
(let [schema {:id sc/Int, :name sc/Str}
string->edn (scc/coercer schema scc/string-coercion-matcher)]
(assert (= {:id 1, :name "kikka"}
(string->edn {:id 1, :name "kikka"})
(string->edn {:id "1", :name "kikka"})))
(p/bench (string->edn {:id "1", :name "kikka"})))
;;
;; no-op coercion
;;
;; 15µs
(let [spec (s/keys :req-un [::id ::name])
string->edn #(st/coerce spec % st/json-transformer)]
(assert (= {:id 1, :name "kikka"}
(string->edn {:id 1, :name "kikka"})))
(p/bench (string->edn {:id 1, :name "kikka"})))
;; 3.0ns
(let [schema [:map [:id int?] [:name string?]]
string->edn (m/decoder schema mt/json-transformer)]
(assert (= {:id 1, :name "kikka"}
(string->edn {:id 1, :name "kikka"})))
(p/bench (string->edn {:id 1, :name "kikka"}))))
(def tests
[;; 1.7ns -> 4.5ns
[int? 1]
;; 5.8ns -> 11ns
[[:and int? [:> 2]] 3]
;; 107ns -> 122ns
[[:vector int?] [1 2 3]]
;; 17ns -> 34ns
[[:map [:x int?] [:y boolean?]] {:x 1, :y true}]])
(defn basic-perf []
(doseq [[schema value] tests
:let [validator (m/validator schema)]]
(println)
(println (m/form schema))
(println "-------------")
(p/bench (validator value))))
(defn fn-test []
(let [f (fn [x] (> x 10))
f2 (eval '(fn [x] (> x 10)))
f3 (m/eval '(fn [x] (> x 10)))]
;; 4ns
(p/bench (f 12))
;; 8ns
(p/bench (f2 12))
;; 7000ns -> 73ns
(p/bench (f3 12))))
(defn map-transform-test []
(doseq [transformer [mt/json-transformer
(mt/transformer
mt/strip-extra-keys-transformer
mt/json-transformer)]]
;; 3ns -> 3ns
;; 520ns -> 130ns
(let [>> (m/decoder [:map [:x string?] [:y int?]] transformer)]
(p/bench (>> {:x "1", :y 1})))))
(defn select-keys-perf-test []
(let [ks #{:a :b}
quick-select-keys (fn [x] (reduce (fn [acc k] (if-not (ks k) (dissoc acc k) acc)) x (keys x)))
normal-select-keys (fn [x] (select-keys x ks))]
(assert (= {:a 1, :b 2} (normal-select-keys {:a 1, :b 2, :c 3})))
(assert (= {:a 1, :b 2} (quick-select-keys {:a 1, :b 2, :c 3})))
;; 370ns
(p/bench (normal-select-keys {:a 1, :b 2}))
(p/bench (normal-select-keys {:a 1, :b 2, :c 3, :d 4}))
;; 110ns
(p/bench (quick-select-keys {:a 1, :b 2}))
(p/bench (quick-select-keys {:a 1, :b 2, :c 3, :d 4}))))
(defn sequence-perf-test []
;; 27µs
(let [valid? (partial s/valid? (s/* int?))]
(p/bench (valid? (range 10))))
;; 2.7µs
(let [valid? (m/validator [:* int?])]
(p/bench (valid? (range 10)))))
(defn simple-regex []
(let [data ["-server" "foo" "-verbose" "-verbose" "-user" "joe"]
seqxp (se/*
(se/as [:opts]
(se/cat
(se/as [:opts :prop] string?)
(se/as [:opts :val] (se/|
(se/as [:opts :val :s] string?)
(se/as [:opts :val :b] boolean?))))))
valid-seqxp? (partial se/exec-tree seqxp)
spec (s/* (s/cat :prop string?,
:val (s/alt :s string?
:b boolean?)))
valid-spec? (partial s/valid? spec)
minimallist (mh/* (mh/cat [:prop (mh/fn string?)]
[:val (mh/alt [:s (mh/fn string?)]
[:b (mh/fn boolean?)])]))
valid-minimallist? (partial mc/valid? minimallist)
malli [:* [:catn
[:prop string?]
[:val [:altn
[:s string?]
[:b boolean?]]]]]
valid-malli? (m/validator malli)]
;; 90µs
(p/bench (valid-seqxp? data))
;; 40µs
(p/bench (valid-spec? data))
;; 12µs
(p/bench (valid-minimallist? data))
;; 1.5µs
(p/bench (valid-malli? data))))
(defn parsing []
;; 44µs
(let [spec (s/* (s/cat :prop string?,
:val (s/alt :s string?
:b boolean?)))
parse (partial s/conform spec)]
(p/bench
(parse ["-server" "foo" "-verbose" "-verbose" "-user" "joe"])))
;; 2.5µs
(let [schema [:* [:catn
[:prop string?]
[:val [:altn
[:s string?]
[:b boolean?]]]]]
parse (m/parser schema)]
(p/bench
(parse ["-server" "foo" "-verbose" "-verbose" "-user" "joe"]))))
(defn and-map-perf-test []
;; 164ns -> 36ns
(let [valid? (m/validator (into [:and] (map (fn [x] [:> x]) (range 5))))]
(p/bench (valid? 5)))
;; 150ns -> 126n -> 39ns -> 32ns
(let [->key #(keyword (str "key_" %))
valid? (m/validator (into [:map] (map (fn [x] [(->key x) :any]) (range 5))))
value (reduce (fn [acc x] (assoc acc (->key x) x)) {} (range 5))]
(p/bench (valid? value))))
(defn schema-flames []
;; "Elapsed time: 10472.153783 msecs"
;; "Elapsed time: 524.153783 msecs"
(time
(prof/profile
(dotimes [_ 50000]
(m/validate [:map [:street :string]] {:street "hämeenkatu"}))))
;; "Elapsed time: 231.093848 msecs"
(let [schema (m/schema [:map [:street :string]])]
(time
(prof/profile
(dotimes [_ 500000]
(m/validate schema {:street "hämeenkatu"})))))
;; "Elapsed time: 59.743646 msecs"
(let [validate (m/validator [:map [:street :string]])]
(time
(prof/profile
(dotimes [_ 500000]
(validate {:street "hämeenkatu"}))))))
(defn address-flame []
(time
(prof/profile
(dotimes [_ 1000]
(m/schema
[:schema
{:registry {"Country" [:map
{:closed true}
[:name [:enum :FI :PO]]
[:neighbors
{:optional true}
[:vector [:ref "Country"]]]],
"Burger" [:map
[:name string?]
[:description {:optional true} string?]
[:origin [:maybe "Country"]]
[:price pos-int?]],
"OrderLine" [:map
{:closed true}
[:burger "Burger"]
[:amount int?]],
"Order" [:map
{:closed true}
[:lines [:vector "OrderLine"]]
[:delivery
[:map
{:closed true}
[:delivered boolean?]
[:address
[:map
[:street string?]
[:zip int?]
[:country "Country"]]]]]]}}
"Order"])))))
(defn provider-test []
;; 3.6ms
;; 2.1ms (1.7x)
(p/bench (mp/provide [1 2 3]))
;; 2.6ms
(p/bench (mp/provider))
;; 2.5ms
;; 54µs (46x)
(let [provider (mp/provider)]
(p/bench (provider [1 2 3]))))
(defn provider-test2 []
(let [samples [{:id "Lillan"
:tags #{:artesan :coffee :hotel}
:address {:street "Ahlmanintie 29"
:city "Tampere"
:zip 33100
:lonlat [61.4858322, 23.7854658]}}
{:id "Huber",
:description "Beefy place"
:tags #{:beef :wine :beer}
:address {:street "Aleksis Kiven katu 13"
:city "Tampere"
:zip 33200
:lonlat [61.4963599 23.7604916]}}]]
;; 126ms -> 2.5ms
(p/bench (mp/provide samples))
;; 26ms
;; 380µs, no exceptions, (330x)
(let [provide (mp/provider)]
(p/bench (provide samples)))
;; 270µs, no exceptions, no inst? (460x)
(let [registry (dissoc (m/default-schemas) inst? 'inst?)
provide (mp/provider {:registry registry})]
(p/bench (provide samples)))))
(comment
(map-perf)
(composite-perf)
(composite-perf2)
(composite-explain-perf)
(basic-perf)
(transform-test)
(transform-test2)
(map-transform-test)
(select-keys-perf-test)
(fn-test)
(sequence-perf-test)
(simple-regex)
(parsing)
(and-map-perf-test)
(provider-test)
(provider-test2)
(p/clear!)
(address-flame)
(schema-flames))
(comment
(let [f (m/eval '(fn [x] (> x 10)))]
(time
(prof/profile
(dotimes [_ 5000000]
(f 12))))))
malli/pom.xml
Vendored
+74
View File
@@ -0,0 +1,74 @@
<?xml version="1.0" encoding="UTF-8"?>
<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">
<modelVersion>4.0.0</modelVersion>
<groupId>metosin</groupId>
<artifactId>malli</artifactId>
<version>0.20.0</version>
<name>malli</name>
<description>High-performance data-driven data specification library for Clojure/Script.</description>
<licenses>
<license>
<name>Eclipse Public License 2.0</name>
<url>https://www.eclipse.org/legal/epl-2.0/</url>
</license>
</licenses>
<scm>
<url>https://github.com/metosin/malli</url>
<connection>scm:git:git://github.com/metosin/malli.git</connection>
<developerConnection>scm:git:ssh://git@github.com/metosin/malli.git</developerConnection>
<tag>0.20.0</tag>
</scm>
<dependencies>
<dependency>
<groupId>org.clojure</groupId>
<artifactId>clojure</artifactId>
<version>1.12.3</version>
</dependency>
<dependency>
<groupId>fipp</groupId>
<artifactId>fipp</artifactId>
<version>0.6.29</version>
</dependency>
<dependency>
<groupId>mvxcvi</groupId>
<artifactId>arrangement</artifactId>
<version>2.1.0</version>
</dependency>
<dependency>
<groupId>borkdude</groupId>
<artifactId>dynaload</artifactId>
<version>0.3.5</version>
</dependency>
<dependency>
<groupId>borkdude</groupId>
<artifactId>edamame</artifactId>
<version>1.4.32</version>
</dependency>
<dependency>
<groupId>org.clojure</groupId>
<artifactId>test.check</artifactId>
<version>1.1.1</version>
</dependency>
</dependencies>
<build>
<sourceDirectory>src</sourceDirectory>
<resources>
<resource>
<directory>src</directory>
</resource>
</resources>
</build>
<repositories>
<repository>
<id>clojars</id>
<url>https://repo.clojars.org/</url>
</repository>
</repositories>
<distributionManagement>
<repository>
<id>clojars</id>
<name>Clojars repository</name>
<url>https://clojars.org/repo</url>
</repository>
</distributionManagement>
</project>
malli/public/index.html
Vendored
+11
View File
@@ -0,0 +1,11 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<title>Malli instrument dev</title>
</head>
<body>
<div id="app">Open the devtools and connect a shadow-cljs repl.</div>
<script src="js/instrument/app.js"></script>
</body>
</html>
malli/resources/clj-kondo/clj-kondo.exports/metosin/malli/config.edn
Vendored
+2
View File
@@ -0,0 +1,2 @@
{:lint-as {malli.experimental/defn schema.core/defn}
:linters {:unresolved-symbol {:exclude [(malli.core/=>)]}}}
malli/shadow-cljs.edn
Vendored
+63
View File
@@ -0,0 +1,63 @@
{:deps {:aliases [:shadow :sci :cherry]}
:dev-http {8000 "public"}
:builds {:app {:target :browser
:closure-defines {malli.registry/type "default"}
:modules {:cljs {:entries [cljs.core]}
:malli {:entries [malli.core]
:depends-on #{:cljs}}
:app {:entries [malli.app]
:depends-on #{:malli}}}}
:instrument {:target :browser
:build-options {:cache-level :off}
:output-dir "public/js/instrument"
:asset-path "/js/instrument"
:modules {:app {:entries [malli.instrument-app]
:preloads [malli.dev.cljs-kondo-preload malli.dev-preload]
:init-fn malli.instrument-app/init}}}
:app-sci {:target :browser
:closure-defines {malli.registry/type "default"}
:devtools {:preloads [sci.core]}
:modules {:cljs {:entries [cljs.core]}
:sci {:entries [sci.core]
:depends-on #{:cljs}}
:malli {:entries [malli.core]
:depends-on #{:cljs :sci}}
:app {:entries [malli.app]
:depends-on #{:malli}}}}
:app-cherry {:target :browser
:closure-defines {malli.registry/type "default"}
:devtools {:preloads [malli.cherry]}
:modules {:cljs {:entries [cljs.core]}
:malli {:entries [malli.core]
:depends-on #{:cljs}}
:cherry {:entries [malli.cherry]
:depends-on #{:cljs :malli}}
:app {:entries [malli.app]
:depends-on #{:malli :cherry}}}}
:app2 {:target :browser
:closure-defines {malli.registry/type "custom"}
:modules {:cljs {:entries [cljs.core]}
:malli {:entries [malli.core]
:depends-on #{:cljs}}
:app {:entries [malli.app2]
:depends-on #{:malli :cljs}}}}
:app2-sci {:target :browser
:closure-defines {malli.registry/type "custom"}
:devtools {:preloads [sci.core]}
:modules {:cljs {:entries [cljs.core]}
:sci {:entries [sci.core]
:depends-on #{:cljs}}
:malli {:entries [malli.core]
:depends-on #{:cljs :sci}}
:app {:entries [malli.app2]
:depends-on #{:malli}}}}
:app2-cherry {:target :browser
:closure-defines {malli.registry/type "default"}
:devtools {:preloads [malli.cherry]}
:modules {:cljs {:entries [cljs.core]}
:malli {:entries [malli.core]
:depends-on #{:cljs}}
:cherry {:entries [malli.cherry]
:depends-on #{:cljs :malli}}
:app {:entries [malli.app2]
:depends-on #{:cherry}}}}}}
malli/src/malli/cherry.cljs
Vendored
+23
View File
@@ -0,0 +1,23 @@
(ns ^:no-doc malli.cherry
(:refer-clojure :exclude [eval])
(:require [cherry.embed :as cherry]
[malli.core]))
(cherry/preserve-ns 'cljs.core)
(cherry/preserve-ns 'malli.core) ;; we could be more fine-grained here with another API fn, e.g (cherry/preserve-var 'malli.core/...)
(cherry/preserve-ns 'clojure.string)
(def cherry-opts {:aliases {'m 'malli.core
'str 'clojure.string}})
(defn eval
([code] (eval code nil))
([code _opts]
(cond (or (symbol? code)
(seq? code))
(cherry/eval-form code cherry-opts)
(string? code)
(cherry/eval-string code cherry-opts)
:else code)))
(set! malli.core/eval eval)
malli/src/malli/clj_kondo.cljc
Vendored
+250
View File
@@ -0,0 +1,250 @@
(ns malli.clj-kondo
#?(:cljs (:require-macros [malli.clj-kondo]))
(:require [fipp.edn :as fipp]
[malli.core :as m]
#?(:clj [clojure.java.io :as io])))
(declare transform)
(defmulti accept (fn [name _schema _children _options] name) :default ::default)
(defmethod accept ::default [_ schema _ _] (if (m/-function-schema? schema) :fn :any))
(defmethod accept 'any? [_ _ _ _] :any)
(defmethod accept 'some? [_ _ _ _] :any) ;;??
(defmethod accept 'number? [_ _ _ _] :number)
(defmethod accept 'integer? [_ _ _ _] :int)
(defmethod accept 'int? [_ _ _ _] :int)
(defmethod accept 'pos-int? [_ _ _ _] :pos-int)
(defmethod accept 'neg-int? [_ _ _ _] :neg-int)
(defmethod accept 'nat-int? [_ _ _ _] :nat-int)
(defmethod accept 'nat-int? [_ _ _ _] :nat-int)
(defmethod accept 'pos? [_ _ _ _] :pos-int)
(defmethod accept 'neg? [_ _ _ _] :neg-int)
(defmethod accept 'float? [_ _ _ _] :double)
(defmethod accept 'double? [_ _ _ _] :double)
(defmethod accept 'boolean? [_ _ _ _] :boolean)
(defmethod accept 'string? [_ _ _ _] :string)
(defmethod accept 'ident? [_ _ _ _] :symbol) ;;??
(defmethod accept 'simple-ident? [_ _ _ _] :symbol) ;;??
(defmethod accept 'qualified-ident? [_ _ _ _] :symbol) ;;??
(defmethod accept 'keyword? [_ _ _ _] :keyword)
(defmethod accept 'simple-keyword? [_ _ _ _] :keyword)
(defmethod accept 'qualified-keyword? [_ _ _ _] :keyword)
(defmethod accept 'symbol? [_ _ _ _] :symbol)
(defmethod accept 'simple-symbol? [_ _ _ _] :symbol)
(defmethod accept 'qualified-symbol? [_ _ _ _] :symbol)
(defmethod accept 'uuid? [_ _ _ _] :any) ;;??
(defmethod accept 'uri? [_ _ _ _] :any) ;;??
(defmethod accept 'decimal? [_ _ _ _] :double) ;;??
(defmethod accept 'inst? [_ _ _ _] :any) ;;??
(defmethod accept 'seqable? [_ _ _ _] :seqable)
(defmethod accept 'indexed? [_ _ _ _] :vector) ;;??
(defmethod accept 'map? [_ _ _ _] :map)
(defmethod accept 'vector? [_ _ _ _] :vector)
(defmethod accept 'list? [_ _ _ _] :list)
(defmethod accept 'seq? [_ _ _ _] :seq)
(defmethod accept 'char? [_ _ _ _] :char)
(defmethod accept 'set? [_ _ _ _] :set)
(defmethod accept 'nil? [_ _ _ _] :nil)
(defmethod accept 'false? [_ _ _ _] :boolean) ;;??
(defmethod accept 'true? [_ _ _ _] :boolean) ;;??
(defmethod accept 'zero? [_ _ _ _] :int) ;;??
#?(:clj (defmethod accept 'rational? [_ _ _ _] :double)) ;;??
(defmethod accept 'coll? [_ _ _ _] :coll)
(defmethod accept 'empty? [_ _ _ _] :seq) ;;??
(defmethod accept 'associative? [_ _ _ _] :associative)
(defmethod accept 'sequential? [_ _ _ _] :sequential)
(defmethod accept 'ratio? [_ _ _ _] :int) ;;??
(defmethod accept 'bytes? [_ _ _ _] :char-sequence) ;;??
(defmethod accept 'ifn? [_ _ _ _] :ifn)
(defmethod accept 'fn? [_ _ _ _] :fn)
(defmethod accept :> [_ _ _ _] :number) ;;??
(defmethod accept :>= [_ _ _ _] :number) ;;??
(defmethod accept :< [_ _ _ _] :number) ;;??
(defmethod accept :<= [_ _ _ _] :number) ;;??
(defmethod accept := [_ _ _ _] :any) ;;??
(defmethod accept :not= [_ _ _ _] :any) ;;??
(defmethod accept :and [_ _ _ _] :any) ;;??
(defmethod accept :andn [_ _ _ _] :any) ;;??
(defmethod accept :or [_ _ _ _] :any) ;;??
(defmethod accept :orn [_ _ _ _] :any) ;;??
(defmethod accept :not [_ _ _ _] :any) ;;??
(defmethod accept :map [_ _ children _]
(let [{req true opt false} (->> children (group-by (m/-comp not :optional second)))
opt (apply array-map (mapcat (fn [[k _ s]] [k s]) opt))
req (apply array-map (mapcat (fn [[k _ s]] [k s]) req))]
(cond-> {:op :keys}, (seq opt) (assoc :opt opt), (seq req) (assoc :req req))))
(defmethod accept :map-of [_ _ _ _] :map) ;;??
(defmethod accept :vector [_ _ _ _] :vector)
(defmethod accept :sequential [_ _ _ _] :sequential)
(defmethod accept :set [_ _ _ _] :set)
(defmethod accept :enum [_ _ children _]
(let [types (->> children (map type) (set))]
(if (< 1 (count types))
:any
(let [child (first children)]
(cond
(string? child) :string
(keyword? child) :keyword
(integer? child) :int
(char? child) :char
(number? child) :number
(symbol? child) :symbol
:else :any)))))
(defmethod accept :maybe [_ _ [child] _]
(cond
(= :keys (:op child)) (assoc child :nilable true)
(and (keyword? child) (not= :any child)) (keyword "nilable" (name child))
:else child))
(defmethod accept :tuple [_ _ _ _] :seqable)
(defmethod accept :multi [_ _ _ _] :any) ;;??
(defmethod accept :re [_ _ _ _] :string)
(defmethod accept :fn [_ _ _ _] :any)
(defmethod accept :ref [_ _ _ _] :any) ;;??
(defmethod accept :schema [_ schema _ options] (transform (m/deref schema) options))
(defmethod accept ::m/schema [_ schema _ options] (transform (m/deref schema) options))
(defmethod accept ::m/val [_ _ children _] (first children))
(defmethod accept :any [_ _ _ _] :any)
(defmethod accept :nil [_ _ _ _] :nil)
(defmethod accept :string [_ _ _ _] :string)
(defmethod accept :int [_ _ _ _] :int)
(defmethod accept :double [_ _ _ _] :double)
(defmethod accept :boolean [_ _ _ _] :boolean)
(defmethod accept :keyword [_ _ _ _] :keyword)
(defmethod accept :qualified-keyword [_ _ _ _] :keyword)
(defmethod accept :symbol [_ _ _ _] :symbol)
(defmethod accept :qualified-symbol [_ _ _ _] :symbol)
(defmethod accept :uuid [_ _ _ _] :any) ;;??
(defn -seqable-or-rest [[child] {:keys [arity]}]
(if (= arity :varargs)
{:op :rest :spec child}
:seqable))
(defmethod accept :+ [_ _ children options] (-seqable-or-rest children options))
(defmethod accept :* [_ _ children options] (-seqable-or-rest children options))
(defmethod accept :? [_ _ children options] (-seqable-or-rest children options))
(defmethod accept :repeat [_ _ children options] (-seqable-or-rest children options))
(defmethod accept :cat [_ _ children _] children)
(defmethod accept :catn [_ _ children _] (mapv last children))
(defmethod accept :alt [_ _ _ _] :any) ;;??
(defmethod accept :altn [_ _ _ _] :any) ;??
(defmethod accept :merge [_ schema _ options] (transform (m/deref schema) options))
(defmethod accept :union [_ schema _ options] (transform (m/deref schema) options))
(defmethod accept :select-keys [_ schema _ options] (transform (m/deref schema) options))
(defn- -walk [schema _ children options] (accept (m/type schema) schema children options))
(defn -transform [?schema options] (m/walk ?schema -walk options))
#?(:clj
(defn -file-in-kondo-dir [options & paths]
(apply io/file (into (get options :clj-kondo-dir-path []) paths))))
#?(:clj
(defn -types-dir-name
"Creates a directory name such as `malli-types-cljs` or `malli-types-clj`."
[key]
(str "malli-types-" (name key))))
#?(:clj
(defn -config-file-path [key options]
(-file-in-kondo-dir options ".clj-kondo" "imports" "metosin" (-types-dir-name key) "config.edn")))
;;
;; public api
;;
#?(:clj
(defn clean!
"Cleans existing configurations from .clj-kondo directory"
([options]
(clean! :clj options))
([key options]
(.delete (-config-file-path key options))
;; These are remnants from old locations where malli used to store the configuration files
(.delete (-file-in-kondo-dir options ".clj-kondo" "metosin" (-types-dir-name key) "config.edn"))
(.delete (-file-in-kondo-dir options ".clj-kondo" "configs" "malli" "config.edn")))))
(defn transform
([?schema]
(transform ?schema nil))
([?schema options]
(-transform ?schema options)))
#?(:clj
(defn save!
"config:
- :clj-kondo-dir-path : optional, path to the .clj-kondo directory"
([config]
(save! config :clj))
([config key]
(save! config key nil))
([config key options]
(let [cfg-file (-config-file-path key options)]
(io/make-parents cfg-file)
(spit cfg-file (with-out-str (fipp/pprint config {:width 120})))
config))))
(defn from [{?schema :schema :keys [ns name]}]
(let [ns-name (-> ns str symbol)
schema (m/function-schema ?schema)]
(reduce
(fn [acc schema]
(let [{:keys [input output arity min]} (m/-function-info schema)
args (transform input {:arity arity})
ret (transform output)]
(conj acc (cond-> {:ns ns-name
:name name
:arity arity
:args args
:ret ret}
(= arity :varargs) (assoc :min-arity min)))))
[] (or (seq (m/-function-schema-arities schema))
(m/-fail! ::from-requires-function-schema {:schema schema})))))
(defn collect
([] (collect nil))
([ns]
(let [-collect (fn [k] (or (nil? ns) (= k (symbol (str ns)))))]
(for [[k vs] (m/function-schemas) :when (-collect k) [_ v] vs v (from v)] v))))
(defn linter-config [xs]
(reduce
(fn [acc {:keys [ns name arity] :as data}]
(assoc-in
acc [:linters :type-mismatch :namespaces ns name :arities arity]
(select-keys data [:args :ret :min-arity])))
{:linters {:unresolved-symbol {:exclude ['(malli.core/=>)]}}} xs))
#?(:clj
(defn emit!
([] (emit! {}))
([options] (-> (collect) (linter-config) (save! :clj options)) nil)))
(defn collect-cljs
([] (collect-cljs nil))
([ns]
(let [-collect (fn [k] (or (nil? ns) (= k (symbol (str ns)))))]
(for [[k vs] (m/function-schemas :cljs) :when (-collect k) [_ v] vs v (from v)] v))))
#?(:cljs
(defn get-kondo-config []
(-> (collect-cljs) (linter-config))))
#?(:cljs
(defn- print!* [config]
(js/console.log (with-out-str (fipp/pprint config {:width 120})))))
#?(:cljs
(defn print-cljs! []
(-> (get-kondo-config) (print!*)) nil))
malli/src/malli/core.cljc
Vendored
+3147
View File
File diff suppressed because it is too large Load Diff
malli/src/malli/destructure.cljc
Vendored
+167
View File
@@ -0,0 +1,167 @@
(ns malli.destructure
(:require [clojure.walk :as walk]
[malli.core :as m]))
(defn -map-like? [x] (or (map? x) (and (seqable? x) (every? (fn [e] (and (vector? e) (= 2 (count e)))) x))))
(defn -qualified-key? [k] (and (qualified-keyword? k) (-> k name #{"keys" "syms"})))
(def MapLike (m/-collection-schema {:type 'MapLike, :empty {}, :pred -map-like?}))
(def Never (m/-simple-schema {:type 'Never, :pred (fn [_] false)}))
(defn -create [inline-schemas]
(m/schema
[:schema
{:registry {"Schema" any?
"Amp" [:= '&]
"As" [:= :as]
"Symbol" [:and symbol? [:not "Amp"]]
"Separator" (if inline-schemas [:= :-] Never)
"Map" [MapLike
[:or
[:tuple [:= :keys] [:vector ident?]]
[:tuple [:= :strs] [:vector ident?]]
[:tuple [:= :syms] [:vector ident?]]
[:tuple [:= :or] [:map-of simple-symbol? any?]]
[:tuple [:= :as] "Symbol"]
[:tuple [:fn -qualified-key?] [:vector ident?]]
[:tuple [:ref "ArgType"] any?]]]
"Vector" [:catn
[:elems [:* "Arg"]]
[:rest [:? [:catn
[:amp "Amp"]
[:arg "Arg"]]]]
[:as [:? [:catn
[:as "As"]
[:sym "Symbol"]
[:schema [:? [:catn
[:- "Separator"]
[:schema "Schema"]]]]]]]]
"ArgType" [:orn
[:sym "Symbol"]
[:map "Map"]
[:vec [:schema [:ref "Vector"]]]]
"Arg" [:alt
[:catn
[:arg "ArgType"]]
[:catn
[:arg "ArgType"]
[:- "Separator"]
[:schema "Schema"]]]
"Binding" [:catn
[:elems [:* "Arg"]]
[:rest [:? [:catn
[:amp "Amp"]
[:arg "Arg"]]]]]}}
"Binding"]))
(def Binding (-create false))
(def SchematizedBinding (-create true))
(declare -transform)
(defn -any? [x] (= :any x))
(defn -maybe? [x] (and (vector? x) (= :maybe (first x))))
(defn -vector [{{:keys [as elems rest]} :values} options]
(or (some->> as :values :schema :values :schema (conj [:schema]))
(let [ess (map #(let [s (-transform % options false)] (cond->> s (not (-maybe? s)) (conj [:?]))) elems)
rs (if rest (-transform (:arg (:values rest)) options true) [:* :any])]
[:maybe (if (seq ess) (-> [:cat] (into ess) (conj rs)) [:cat rs])])))
(defn -qualified-keys [m]
(for [[k vs] m
:when (-qualified-key? k)
:let [f ({"keys" keyword, "syms" symbol} (name k))]
:when f, v vs] (f (namespace k) (str v))))
(defn -keys [{:keys [keys strs syms] :as arg} {:keys [::references] :or {references true} :as options}]
(let [any (fn [f ks] (map (fn [k] [(f k) :any]) ks))]
(->> (concat (any keyword keys) (any str strs) (any identity syms)
(map (fn [k] [k (if (and references (qualified-keyword? k)) k :any)]) (-qualified-keys arg))
(map (fn [[k v]] [v (-transform (m/tags {:arg k}) options false)]) (filter #(m/tag? (key %)) arg)))
(distinct))))
(defn -map [arg {:keys [::references ::required-keys ::closed-maps ::sequential-maps]
:or {references true, sequential-maps true} :as options} rest]
(let [keys (-keys arg options)
->entry (fn [[k t]] (let [ref (and references (qualified-keyword? k))]
(cond (and ref required-keys) k
required-keys [k t]
:else (cond-> [k {:optional true}] (not ref) (conj t)))))
->arg (fn [[k t]] [:cat [:= k] (if (and references (qualified-keyword? k)) k t)])
schema (cond-> [:map] closed-maps (conj {:closed true}) :always (into (map ->entry keys)))]
(if (or rest sequential-maps)
[:orn [:map schema] [:args (-> (into [:alt] (map ->arg) keys)
(cond-> (not closed-maps) (conj [:cat [:not (into [:enum] (map first) keys)] :any]))
(cond->> :always (conj [:*]) (not rest) (conj [:schema])))]]
schema)))
(defn -transform [{{{k :key v :value} :arg schema :schema :as all} :values} options rest]
(cond (and schema rest) (let [s (-transform all options false)] (if (-any? s) schema s))
schema schema
(= :vec k) (-vector v options)
(= :map k) (-map v options rest)
rest [:* :any]
:else :any))
(defn -schema [{{:keys [elems rest]} :values} options]
(cond-> :cat
(or (seq elems) rest) (vector)
(seq elems) (into (map #(-transform % options false) elems))
rest (conj (-transform (:arg (:values rest)) options true))))
(defn -unschematize [x]
(walk/prewalk #(cond-> % (and (map? %) (:- %)) (dissoc :- :schema)) x))
(defn -function-schema
([arglists] (-function-schema arglists nil))
([arglists options]
(let [->schema (fn [arglist] [:=> (-schema (m/parse SchematizedBinding arglist) options) :any])]
(as-> (map ->schema arglists) $ (if (next $) (into [:function] $) (first $))))))
;;
;; public api
;;
(defn parse
"Takes a destructuring bindings vector (arglist)
and returns a map with keys:
| key | description |
| ---------------|-------------|
| `:raw-arglist` | the original arglist (can have type-hints)
| `:arglist` | simplified clojure arglist (no type-hints)
| `:schema` | extracted malli schema
| `:parsed` | full parse results
Parsing can be configured using the following options:
| key | description |
| -----------------------|-------------|
| `::md/inline-schemas` | support plumatic-style inline schemas (true)
| `::md/sequential-maps` | support sequential maps in non-rest position (true)
| `::md/references` | qualified schema references used (true)
| `::md/required-keys` | destructured keys are required (false)
| `::md/closed-maps` | destructured maps are closed (false)
Examples:
(require '[malli.destructure :as md])
(-> '[a b & cs] (md/parse) :schema)
; => [:cat :any :any [:* :any]]
(-> '[a :- :string, b & cs :- [:* :int]] (md/parse) :schema)
; => [:cat :string :any [:* :int]]"
([arglist] (parse arglist nil))
([arglist {:keys [::inline-schemas] :or {inline-schemas true} :as options}]
(let [parse-scheme (if inline-schemas SchematizedBinding Binding)
parsed (m/parse parse-scheme arglist)
arglist' (->> parsed (-unschematize) (m/unparse Binding))
schema' (-schema parsed options)]
(when (= ::m/invalid arglist') (m/-fail! ::invalid-arglist {:arglist arglist}))
{:raw-arglist arglist, :parsed parsed, :arglist arglist', :schema schema'})))
(defn infer
"Infers a schema from a function Var. Best effort."
([var] (infer var nil))
([var options] (-> var meta :arglists (-function-schema options))))
malli/src/malli/dev.clj
Vendored
+64
View File
@@ -0,0 +1,64 @@
(ns malli.dev
(:require [malli.clj-kondo :as clj-kondo]
[malli.core :as m]
[malli.dev.pretty :as pretty]
[malli.instrument :as mi]))
(defn -log!
([text] (-log! text (pretty/-printer)))
([text printer] (pretty/-log! text printer)))
(defn -capture-fail!
([] (-capture-fail! nil))
([{:keys [report] :or {report (pretty/reporter)}}]
(alter-var-root
#'m/-fail!
(fn [f] (-> (fn -fail!
([type] (-fail! type nil))
([type data] (let [e (m/-exception type data)]
(report type data)
(throw e))))
(with-meta {::original f}))))))
(defn -uncapture-fail! []
(alter-var-root #'m/-fail! (fn [f] (-> f meta ::original (or f)))))
;;
;; Public API
;;
(defn stop!
"Stops instrumentation for all functions vars and removes clj-kondo type annotations."
[]
(remove-watch @#'m/-function-schemas* ::watch)
(->> (mi/unstrument!) (count) (format "unstrumented %d function vars") (-log!))
(clj-kondo/save! {})
(-uncapture-fail!)
(-log! "dev-mode stopped"))
(defn start!
"Collects defn schemas from all loaded namespaces and starts instrumentation for
a filtered set of function Vars (e.g. `defn`s). See [[malli.core/-instrument]]
for possible options. Re-instruments if the function schemas change. Also emits
clj-kondo type annotations."
([] (start! {:report (pretty/reporter)}))
([options]
(with-out-str (stop!))
(-capture-fail! options)
(mi/collect! {:ns (all-ns)})
(let [watch (bound-fn [_ _ old new]
(->> (for [[n d] (:clj new)
:let [no (get-in old [:clj n])]
[s d] d
:when (not= d (get no s))]
[[n s] d])
(into {})
(reduce-kv assoc-in {})
(assoc options :data)
(mi/instrument!))
(clj-kondo/emit! options))]
(add-watch @#'m/-function-schemas* ::watch watch))
(let [count (->> (mi/instrument! options) (count))]
(when (pos? count) (-log! (format "instrumented %d function vars" count))))
(clj-kondo/emit! options)
(-log! "dev-mode started")))
malli/src/malli/dev/cljs.cljc
Vendored
+44
View File
@@ -0,0 +1,44 @@
(ns malli.dev.cljs
#?(:cljs (:require-macros [malli.dev.cljs]))
#?(:cljs (:require [malli.core :as m]
[malli.dev.pretty :as pretty]
[malli.instrument]))
#?(:clj (:require [cljs.analyzer.api :as ana-api]
[malli.clj-kondo :as clj-kondo]
[malli.core :as m]
[malli.instrument])))
#?(:clj (defmacro stop!
"Stops instrumentation for all functions vars and removes clj-kondo type annotations."
[]
`(do (malli.instrument/unstrument! nil)
~(do (clj-kondo/save! {}) nil))))
#?(:clj (defmacro collect-all! [] (malli.instrument/collect! {:ns (ana-api/all-ns)})))
#?(:clj
(defmacro start!
"Collects defn schemas from all loaded namespaces and starts instrumentation for
a filtered set of function Vars (e.g. `defn`s). See [[malli.core/-instrument]] for possible options.
Differences from Clojure `malli.dev/start!`:
- The :ns option must be a compile-time literal as the namespace symbol(s) must be available at compile time, not runtime.
- Does not unstrument functions - this is handled by hot reloading.
- Does not emit clj-kondo type annotations. See `malli.clj-kondo/print-cljs!` to print clj-kondo config.
- Does not re-instrument functions if the function schemas change - use hot reloading to get a similar effect."
([] `(start! {:report (malli.dev.pretty/thrower) :skip-instrumented? true}))
([options]
;; register all function schemas and instrument them based on the options
;; first clear out all metadata schemas to support dev-time removal of metadata schemas on functions - they should not be instrumented
`(do
(m/-deregister-metadata-function-schemas! :cljs)
(malli.instrument/collect! {:ns ~(if (:ns options)
(:ns options)
(vec (ana-api/all-ns)))})
(malli.instrument/instrument! (assoc ~options :data (m/function-schemas :cljs)))
(js/console.groupCollapsed "Instrumentation done")
(js/console.groupEnd)))))
;; only used by deprecated malli.instrument.cljs implementation
#?(:clj (defmacro deregister-function-schemas! []
(m/-deregister-function-schemas! :cljs)
nil))
malli/src/malli/dev/cljs_kondo_preload.cljc
Vendored
+49
View File
@@ -0,0 +1,49 @@
(ns ^:no-doc malli.dev.cljs-kondo-preload
"Shadow-cljs preload for browser builds, used to persist clj-kondo config collected from function schemas to disk during development."
#?(:cljs (:require-macros [malli.dev.cljs-kondo-preload]))
(:require [malli.clj-kondo :as clj-kondo]
#?@(:cljs
[[shadow.cljs.devtools.client.shared :as client.shared]
[shadow.cljs.devtools.client.env :as env]
[shadow.remote.runtime.api :as api]
[shadow.remote.runtime.shared :as runtime]])
#?@(:clj
[[shadow.cljs.devtools.server.worker.impl :as worker]])))
#?(:cljs
(defn send-kondo-config-to-shadow!
"During development sends the clj-kondo config data for all collected functions with malli schemas to the shadow-cljs clojure runtime which writes it to disk."
{:dev/after-load true}
[]
(runtime/relay-msg
@client.shared/runtime-ref
{:op ::clj-kondo/write-config
:to env/worker-client-id
:build-id (keyword env/build-id)
:data (clj-kondo/get-kondo-config)})))
;; The following sends the config on first load of the app, the above function handles hot-reloads.
#?(:cljs
(client.shared/add-plugin!
::client #{}
(fn [{:keys [runtime] :as env}]
(api/add-extension runtime ::client
{:on-welcome
(fn [] (send-kondo-config-to-shadow!))
:on-disconnect
(fn [e])
:on-reconnect
(fn [e] (send-kondo-config-to-shadow!))})
env)
(fn [{:keys [runtime]}]
(api/del-extension runtime ::client))))
#?(:clj
(defmethod worker/do-relay-msg ::clj-kondo/write-config
[worker-state msg]
(clj-kondo/save! (:data msg) :cljs)
worker-state))
malli/src/malli/dev/cljs_noop.cljc
Vendored
+7
View File
@@ -0,0 +1,7 @@
(ns malli.dev.cljs-noop
#?(:cljs (:require-macros [malli.dev.cljs-noop])))
#?(:clj (defmacro stop! []))
#?(:clj (defmacro collect-all! []))
#?(:clj (defmacro start! ([]) ([_options])))
#?(:clj (defmacro deregister-function-schemas! []))
malli/src/malli/dev/pretty.cljc
Vendored
+190
View File
@@ -0,0 +1,190 @@
(ns malli.dev.pretty
(:require [malli.core :as m]
[malli.dev.virhe :as v]
[malli.error :as me]
[malli.edn :as edn]
[malli.registry :as mr]))
(defn -printer
([] (-printer nil))
([options]
(v/-printer
(merge {:title "Schema Error"
:width 80
:colors v/-dark-colors
:unknown (fn [x] (when (m/schema? x) (m/form x)))
:throwing-fn-top-level-ns-names ["malli" "clojure" "malli" "nrepl"]
::me/mask-valid-values '...}
options))))
(defn -errors [explanation printer]
(->> (for [error (->> explanation (me/with-error-messages) :errors)]
(v/-visit (into {} error) printer)) (interpose :break)))
(defn -explain [schema value printer] (-errors (m/explain schema value) printer))
(defn -log! [text printer]
(-> [:group (v/-color :title "malli: " printer) text]
(v/-print-doc printer)))
(defn -ref-text [printer]
[:group "Reference should be one of the following" :break :break
"- a qualified keyword, " (v/-visit [:ref :user/id] printer) :break
"- a qualified symbol, " (v/-visit [:ref (symbol "'user" "id")] printer) :break
"- a string, " (v/-visit [:ref "user/id"] printer) :break
"- a Var, " (v/-visit [:ref (symbol "#'user" "id")] printer)])
;;
;; formatters
;;
(defmethod v/-format ::m/explain [_ {:keys [schema] :as explanation} printer]
{:body [:group
(v/-block "Value" (v/-visit (me/error-value explanation printer) printer) printer) :break :break
(v/-block "Errors" (v/-visit (me/humanize (me/with-spell-checking explanation)) printer) printer) :break :break
(v/-block "Schema" (v/-visit schema printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})
(defmethod v/-format ::m/coercion [_ {:keys [explain]} printer]
(v/format (m/-exception ::m/explain explain) printer))
(defmethod v/-format ::m/invalid-input [_ {:keys [args input fn-name]} printer]
{:title "Invalid Function Input"
:body [:group
(v/-block "Invalid function arguments" (v/-visit args printer) printer) :break :break
(when fn-name [:span (v/-block "Function Var" (v/-visit fn-name printer) printer) :break :break])
(v/-block "Input Schema" (v/-visit input printer) printer) :break :break
(v/-block "Errors" (-explain input args printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]})
(defmethod v/-format ::m/invalid-output [_ {:keys [value args output fn-name]} printer]
{:title "Invalid Function Output"
:body [:group
(v/-block "Invalid function return value" (v/-visit value printer) printer) :break :break
(when fn-name [:span (v/-block "Function Var" (v/-visit fn-name printer) printer) :break :break])
(v/-block "Function arguments" (v/-visit args printer) printer) :break :break
(v/-block "Output Schema" (v/-visit output printer) printer) :break :break
(v/-block "Errors" (-explain output value printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]})
(defmethod v/-format ::m/invalid-guard [_ {:keys [value args guard fn-name]} printer]
{:title "Function Guard Error"
:body [:group
(when fn-name [:span (v/-block "Function Var" (v/-visit fn-name printer) printer) :break :break])
(v/-block "Guard arguments" (v/-visit [args value] printer) printer) :break :break
(v/-block "Guard Schema" (v/-visit guard printer) printer) :break :break
(v/-block "Errors" (-explain guard [args value] printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]})
(defmethod v/-format ::m/invalid-arity [_ {:keys [args arity schema fn-name]} printer]
{:body [:group
(v/-block (str "Invalid function arity (" arity ")") (v/-visit args printer) printer) :break :break
(v/-block "Function Schema" (v/-visit schema printer) printer) :break :break
#?(:cljs (v/-block "Function Var" (v/-visit fn-name printer) printer)) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]})
(defmethod v/-format ::m/register-function-schema [_ {:keys [ns name schema _data key _exception]} printer]
{:title "Error in registering a Function Schema"
:body [:group
(v/-block "Function Var" [:group
(v/-visit (symbol (str ns) (str name)) printer)
" (" (v/-visit key printer) ")"] printer) :break :break
(v/-block "Function Schema" (v/-visit schema printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT/doc/function-schemas" printer) printer)]})
(defmethod v/-format ::m/invalid-ref [_ {:keys [ref]} printer]
{:body [:group
(v/-block "Invalid Reference" (v/-visit [:ref ref] printer) printer) :break :break
(v/-block "Reason" (-ref-text printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]})
(defmethod v/-format ::m/invalid-schema [_ {:keys [schema form]} printer]
(let [proposals (seq (me/-most-similar-to #{schema} schema (set (keys (mr/schemas m/default-registry)))))]
{:title "Schema Creation Error"
:body [:group
(v/-block "Invalid Schema" (v/-visit form printer) printer) :break :break
(when proposals
[:group (v/-block "Did you mean" (->> (for [proposal proposals] (v/-visit proposal printer)) (interpose :break)) printer)
:break :break])
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}))
(defmethod v/-format ::m/child-error [_ {:keys [type children properties] :as data} printer]
(let [form (m/-raw-form type properties children)
constraints (reduce (fn [acc k] (if-let [v (get data k)] (assoc acc k v) acc)) nil [:min :max])
size (count children)]
{:title "Schema Creation Error"
:body [:group
(v/-block "Invalid Schema" (v/-visit form printer) printer) :break :break
(v/-block "Reason" [:group "Schema has " (v/-visit size printer)
(if (= 1 size) " child" " children")
", expected " (v/-visit constraints printer)] printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}))
(defmethod v/-format ::m/invalid-entry [_ {:keys [entry]} printer]
(let [wrap (if (sequential? entry) vec vector)
wrapped (wrap entry)
example (cond-> wrapped (= 1 (count wrapped)) (conj :any))]
{:title "Schema Creation Error"
:body [:group
(v/-block "Invalid Entry" (v/-visit entry printer) printer) :break :break
(v/-block "Did you mean" (v/-visit example printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}))
(defmethod v/-format ::m/duplicate-keys [_ {:keys [arr]} printer]
(let [keys (->> arr (vec) (take-nth 2))]
{:title "Schema Creation Error"
:body [:group
(v/-block "Duplicate Keys" (v/-visit keys printer) printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}))
(defmethod v/-format :malli.edn/var-parsing-not-supported [_ {:keys [string var]} printer]
(let [parse (fn [string]
(try (edn/-parse-string string {:regex true, :fn true, :var edn/-var-symbol})
(catch #?(:clj Exception, :cljs js/Error) _ string)))]
{:title "Deserialization Error"
:body [:group
(v/-block "Var" (v/-visit var printer) printer) :break :break
(v/-block "Data" (v/-visit (parse string) printer) printer) :break :break
(v/-block "Error" [:group
"Var deserialization is disabled by default, because:" :break :break
"- Vars don't work at runtime in ClojureScript" :break
"- Var resolutions has overhead with GraalVM Native Image"] printer) :break :break
(v/-block "Resolution" [:group
"To deserialize Var with Clojure:" :break :break
(v/-visit `(malli.edn/read-string
~string
{:malli.edn/edamame-options {:regex true, :fn true, :var resolve}})
printer)] printer) :break :break
(v/-block "More information" (v/-link "https://cljdoc.org/d/metosin/malli/CURRENT" printer) printer)]}))
;;
;; public api
;;
(defn reporter
([] (reporter (-printer)))
([printer]
(fn [type data]
(-> (ex-info (str type) {:type type :data data})
(v/exception-document printer)
(v/-print-doc printer)
#?(:cljs (-> with-out-str println))))))
(defn thrower
([] (thrower (-printer)))
([printer]
(let [report (reporter printer)]
(fn [type data]
(let [message (with-out-str (report type data))]
(throw (ex-info message {:type type :data data})))))))
(defn prettifier [type title f options]
(let [printer (assoc (or (::printer options) (assoc (-printer) :width 60)) :title title)
actor (::actor options reporter)]
(fn [& args] (when-let [res (apply f args)] ((actor printer) type res) res))))
(defn explain
([?schema value] (explain ?schema value nil))
([?schema value options]
(let [explain (fn [] (->> (m/explain ?schema value options) (me/with-error-messages)))]
((prettifier ::m/explain "Validation Error" explain options)))))
malli/src/malli/dev/virhe.cljc
Vendored
+205
View File
@@ -0,0 +1,205 @@
(ns malli.dev.virhe
"initial code for https://github.com/metosin/virhe"
(:refer-clojure :exclude [format])
(:require [arrangement.core]
[fipp.edn]
[fipp.ednize]
[fipp.engine]
[fipp.visit]
#?(:clj [clojure.string :as str])))
;;
;; colors
;;
(def -dark-colors
{:title 45
:title-dark 32
:text 253
:link 255
:string 180
:constant 149
:type 123
:error 196})
(defn -color [color body printer]
(let [colors (:colors printer -dark-colors)
color (get colors color (:error colors))]
#?(:cljs [:span body]
:clj (if color
[:span [:pass (str "\033[38;5;" color "m")] body [:pass "\u001B[0m"]]
[:span body]))))
;;
;; EDN
;;
(defrecord EdnPrinter [symbols print-meta print-length print-level unknown]
fipp.visit/IVisitor
(visit-unknown [this x]
(or (and unknown (try (some->> (unknown x) (fipp.visit/visit this))
(catch #?(:clj Exception, :cljs js/Error) _)))
(fipp.visit/visit this (fipp.ednize/edn x))))
(visit-nil [this]
(-color :text "nil" this))
(visit-boolean [this x]
(-color :text (str x) this))
(visit-string [this x]
(-color :string (pr-str x) this))
(visit-character [this x]
(-color :text (pr-str x) this))
(visit-symbol [this x]
(-color :text (str x) this))
(visit-keyword [this x]
(-color :constant (pr-str x) this))
(visit-number [this x]
(-color :text (pr-str x) this))
(visit-seq [this x]
(if-let [pretty (symbols (first x))]
(pretty this x)
(fipp.edn/pretty-coll this (-color :text "(" this) x :line (-color :text ")" this) fipp.visit/visit)))
(visit-vector [this x]
(fipp.edn/pretty-coll this (-color :text "[" this) x :line (-color :text "]" this) fipp.visit/visit))
(visit-map [this x]
(let [xs (sort-by identity (fn [a b] (arrangement.core/rank (first a) (first b))) x)]
(fipp.edn/pretty-coll this (-color :text "{" this) xs [:span (-color :text "," this) :line] (-color :text "}" this)
(fn [printer [k v]]
[:span (fipp.visit/visit printer k) " " (fipp.visit/visit printer v)]))))
(visit-set [this x]
(let [xs (sort-by identity (fn [a b] (arrangement.core/rank a b)) (seq x))]
(fipp.edn/pretty-coll this "#{" xs :line "}" fipp.visit/visit)))
(visit-tagged [this {:keys [tag form]}]
(let [object? (= 'object tag)
tag-f (if (map? form) #(-color :type % this) identity)]
[:group "#" (tag-f (pr-str tag))
(when (or (and print-meta (meta form)) (not (coll? form))) " ")
(if object?
[:group [:align "[" (fipp.visit/visit this (last form))] "]"]
(fipp.visit/visit this form))]))
(visit-meta [this m x]
(if print-meta
[:align [:span "^" (fipp.visit/visit this m)] :line (fipp.visit/visit* this x)]
(fipp.visit/visit* this x)))
(visit-var [_ x]
[:text (str x)])
(visit-pattern [_ x]
[:text (pr-str x)])
(visit-record [this x]
(fipp.visit/visit this (fipp.ednize/record->tagged x))))
(defn -printer
([] (-printer nil))
([options]
(let [defaults {:width 80
:symbols {}
:colors -dark-colors
:print-length *print-length*
:print-level *print-level*
:print-meta *print-meta*}]
(map->EdnPrinter (cond-> defaults options (merge options))))))
(defn -pprint
([x] (-pprint x (-printer)))
([x printer]
(let [printer (dissoc printer :margin)
margin (apply str (take (:margin printer 0) (repeat " ")))]
(binding [*print-meta* false]
(fipp.engine/pprint-document [:group margin [:group (fipp.visit/visit printer x)]] printer)))))
(defn -print-doc [doc printer]
(fipp.engine/pprint-document doc printer))
(defn -visit [x printer]
[:span (fipp.visit/visit printer x)])
#?(:clj
(defn -location [e ss]
(try
(let [[target _ file line] (some (fn [[s :as line]] (if (not-any? #(str/starts-with? (str s) %) ss) line))
(-> e Throwable->map :trace))]
(let [file-name (str/replace file #"(.*?)\.\S[^\.]+" "$1")
target-name (name target)
ns (str (subs target-name 0 (or (str/index-of target-name (str file-name "$")) 0)) file-name)]
(str ns ":" line)))
(catch Exception _))))
#?(:clj
(defn -hierarchy [^Class k]
(loop [sk (.getSuperclass k), ks [k]]
(if-not (= sk Object)
(recur (.getSuperclass sk) (conj ks sk))
ks))))
(defn -title [message source {:keys [width] :as printer}]
(let [between (- width (count message) 8 (count source))]
[:group
(-color :title-dark "-- " printer)
(-color :title [:span message " "] printer)
(-color :title-dark (apply str (take between (repeat "-"))) printer)
(if source
(-color :title [:span " " source " "] printer)
(-color :title-dark "--" printer))
(-color :title-dark "--" printer)]))
(defn -footer [{:keys [width] :as printer}]
(-color :title-dark (apply str (take width (repeat "-"))) printer))
(defn -text [body printer]
(-color :text body printer))
(defn -section [title location body printer]
[:group (-title title location printer) :break :break body :break :break (-footer printer)])
(defn -block [text body printer]
[:group (-text text printer) :break :break
(into [:align 2] (map (fn [x] (if (string? x) (-text x printer) x))
(if (sequential? body) body (vector body))))])
(defn -link [link printer]
(-color :link link printer))
;;
;; formatting
;;
(defmulti -format (fn [e _ _] (-> e (ex-data) :type)) :default ::default)
(defmethod -format ::default [e data printer]
(if-let [-format #?(:clj (some (methods -format) (-hierarchy (class e))), :cljs nil)]
(-format e data printer)
{:title "Unknown Error"
:body [:group
(-block "Type:" (-visit (type e) printer) printer) :break :break
(-block "Message:" (-color :string (ex-message e) printer) printer)
(when-let [data (ex-data e)]
[:group :break :break (-block "Ex-data:" (-visit data printer) printer)])]}))
;;
;; public api
;;
(defn format [e printer]
(-format e (-> e (ex-data) :data) printer))
(defn exception-document [e printer]
(let [{:keys [title body] :or {title (:title printer)}} (format e printer)
location #?(:clj (-location e (:throwing-fn-top-level-ns-names printer)), :cljs nil)]
(-section title location body printer)))
malli/src/malli/dot.cljc
Vendored
+79
View File
@@ -0,0 +1,79 @@
(ns malli.dot
(:require [clojure.string :as str]
[malli.core :as m]
[malli.registry :as mr]
[malli.util :as mu]))
(defn -lift [?schema]
(let [schema (m/schema ?schema)]
(if (and (m/-ref-schema? schema) (-> schema m/deref m/type (= ::m/schema)))
?schema [:schema {:registry {::schema ?schema}} ?schema])))
(defn -collect [schema]
(let [state (atom {})]
(m/walk
schema
(fn [schema _ _ _]
(let [properties (m/properties schema)]
(doseq [[k v] (-> (m/-properties-and-options properties (m/options schema) identity) first :registry)]
(swap! state assoc-in [:registry k] v))
(swap! state assoc :schema schema))))
@state))
(defn -schema-name [base path]
(->> path (remove #{:malli.core/in}) (map (m/-comp str/capitalize m/-keyword->string)) (into [base]) (str/join "$")))
(defn -normalize [{:keys [registry] :as ctx}]
(let [registry* (atom registry)]
(doseq [[k v] registry]
(swap! registry* assoc k
(m/walk v (fn [schema path children _]
(let [options (update (m/options schema) :registry #(mr/composite-registry @registry* %))
schema (m/into-schema (m/parent schema) (m/properties schema) children options)]
(if (and (seq path) (= :map (m/type schema)))
(let [ref (-schema-name k path)]
(swap! registry* assoc ref (mu/update-properties schema assoc ::entity k))
ref)
schema))))))
(assoc ctx :registry @registry*)))
(defn -get-links [registry]
(let [links (atom {})]
(doseq [[from schema] registry]
(m/walk
schema
(fn [schema _ _ _]
(when-let [to (when (m/-ref-schema? schema) (m/-ref schema))]
(swap! links update from (fnil conj #{}) to)))))
@links))
;;
;; public api
;;
(defn transform
([?schema] (transform ?schema nil))
([?schema options]
(let [registry (-> ?schema (m/schema options) -lift -collect -normalize :registry)
entity? #(->> % (get registry) m/properties ::entity)
props #(str "[" (str/join ", " (map (fn [[k v]] (str (name k) "=" (if (fn? v) (v) (pr-str v)))) %)) "]")
esc #(str/escape (str %) {\> "\\>", \{ "\\{", \} "\\}", \< "\\<", \" "\\\""})
sorted #(sort-by (m/-comp str first) %)
wrap #(str "\"" % "\"")
label (fn [k v] (str "\"{" k "|"
(or (some->> (m/entries v) (map (fn [[k s]] (str k " " (esc (m/form (m/deref s)))))) (str/join "\\l"))
(esc (m/form v)))
"\\l}\""))
> #(apply println %&)
>> #(apply > " " %&)]
(with-out-str
(> "digraph {")
(>> "node" (props {:shape "record", :style "filled", :color "#000000"}))
(>> "edge" (props {:dir "back", :arrowtail "none"}))
(>>)
(doseq [[k v] (sorted registry)]
(>> (wrap k) (props {:label #(label k v), :fillcolor (if (entity? k) "#e6caab" "#fff0cd")})))
(>>)
(doseq [[from tos] (sorted (-get-links registry)), to tos]
(>> (wrap from) "->" (wrap to) (props {:arrowtail (if (entity? to) "diamond" "odiamond")})))
(> "}")))))
malli/src/malli/edn.cljc
Vendored
+23
View File
@@ -0,0 +1,23 @@
(ns malli.edn
(:refer-clojure :exclude [read-string])
(:require [edamame.core :as edamame]
[malli.core :as m]))
(defn -var-symbol [s] (symbol (str "#'" s)))
(defn -fail! [s] (fn [v] (m/-fail! ::var-parsing-not-supported {:var (-var-symbol v), :string s})))
(defn -parse-string
([x] (-parse-string x nil))
([x options] (edamame/parse-string x (or options {:regex true, :fn true, :var (-fail! x)}))))
(defn write-string
([?schema]
(write-string ?schema nil))
([?schema options]
(pr-str (m/form ?schema options))))
(defn read-string
([form]
(read-string form nil))
([form {::keys [edamame-options] :as options}]
(m/schema (-parse-string form edamame-options) options)))
malli/src/malli/error.cljc
Vendored
+403
View File
@@ -0,0 +1,403 @@
(ns malli.error
(:require [clojure.string :as str]
[malli.core :as m]
[malli.util :as mu]))
(declare default-errors error-message)
(defn -pr-str [v] #?(:clj (pr-str v), :cljs (str v)))
(defn -pred-min-max-error-fn [{:keys [pred message]}]
(fn [{:keys [schema value negated]} _]
(let [{:keys [min max]} (m/properties schema)]
(cond
(not (pred value)) message
(and min (= min max)) (str "should be " min)
(and min ((if negated >= <) value min)) (str "should be at least " min)
max (str "should be at most " max)
negated message))))
(let [prefix (str "-en-humanize-negation-" (random-uuid))]
(defn- -en-humanize-negation [{:keys [schema negated] :as error} options]
(if negated
(negated (error-message (dissoc error :negated) options))
(let [remove-prefix #(str/replace-first % prefix "")
negated? #(str/starts-with? % prefix)]
(loop [schema schema]
(or (when-some [s (error-message (assoc error :negated #(some->> % (str prefix))) options)]
(if (negated? s)
(remove-prefix s)
(or (when (and (string? s)
(str/starts-with? s "should not "))
(str/replace-first s "should not" "should"))
(when (and (string? s)
(str/starts-with? s "should "))
(str/replace-first s "should" "should not")))))
(let [dschema (m/deref schema)]
(when-not (identical? schema dschema)
(recur dschema)))))))))
(defn- -forward-negation [?schema {:keys [negated] :as error} options]
(let [schema (m/schema ?schema options)]
(negated (error-message (-> error (dissoc :negated) (assoc :schema schema)) options))))
(def default-errors
{::unknown {:error/message {:en "unknown error"}}
::m/missing-key {:error/message {:en "missing required key"}}
::m/limits {:error/fn {:en (fn [{:keys [schema value]} _]
(let [{:keys [min max]} (m/properties schema)]
(cond
(and min (= min max)) (str "should have " min " elements")
(and min (< (count value) min)) (str "should have at least " min " elements")
max (str "should have at most " max " elements"))))}}
::m/tuple-size {:error/fn {:en (fn [{:keys [schema value]} _]
(let [size (count (m/children schema))]
(str "invalid tuple size " (count value) ", expected " size)))}}
::m/invalid-type {:error/message {:en "invalid type"}}
::m/extra-key {:error/message {:en "disallowed key"}}
:malli.core/invalid-dispatch-value {:error/message {:en "invalid dispatch value"}}
::misspelled-key {:error/fn {:en (fn [{::keys [likely-misspelling-of]} _]
(str "should be spelled "
(str/join " or " (map (comp -pr-str last) likely-misspelling-of))))}}
::misspelled-value {:error/fn {:en (fn [{::keys [likely-misspelling-of]} _]
(str "did you mean "
(str/join " or " (map (comp -pr-str last) likely-misspelling-of))))}}
::m/input-remaining {:error/message {:en "input remaining"}}
::m/end-of-input {:error/message {:en "end of input"}}
'any? {:error/message {:en "should be any"}}
'some? {:error/message {:en "should be some"}}
'number? {:error/message {:en "should be a number"}}
'integer? {:error/message {:en "should be an integer"}}
'int? {:error/message {:en "should be an int"}}
'pos-int? {:error/message {:en "should be a positive int"}}
'neg-int? {:error/message {:en "should be a negative int"}}
'nat-int? {:error/message {:en "should be a non-negative int"}}
'pos? {:error/message {:en "should be positive"}}
'neg? {:error/message {:en "should be negative"}}
'float? {:error/message {:en "should be a float"}}
'double? {:error/message {:en "should be a double"}}
'boolean? {:error/message {:en "should be a boolean"}}
'string? {:error/message {:en "should be a string"}}
'ident? {:error/message {:en "should be an ident"}}
'simple-ident? {:error/message {:en "should be a simple ident"}}
'qualified-ident? {:error/message {:en "should be a qualified ident"}}
'keyword? {:error/message {:en "should be a keyword"}}
'simple-keyword? {:error/message {:en "should be a simple keyword"}}
'qualified-keyword? {:error/message {:en "should be a qualified keyword"}}
'symbol? {:error/message {:en "should be a symbol"}}
'simple-symbol? {:error/message {:en "should be a simple symbol"}}
'qualified-symbol? {:error/message {:en "should be a qualified symbol"}}
'uuid? {:error/message {:en "should be a uuid"}}
'uri? {:error/message {:en "should be a uri"}}
#?@(:clj ['decimal? {:error/message {:en "should be a decimal"}}])
'inst? {:error/message {:en "should be an inst"}}
'seqable? {:error/message {:en "should be seqable"}}
'indexed? {:error/message {:en "should be indexed"}}
'map? {:error/message {:en "should be a map"}}
'vector? {:error/message {:en "should be a vector"}}
'list? {:error/message {:en "should be a list"}}
'seq? {:error/message {:en "should be a seq"}}
'char? {:error/message {:en "should be a char"}}
'set? {:error/message {:en "should be a set"}}
'nil? {:error/message {:en "should be nil"}}
'false? {:error/message {:en "should be false"}}
'true? {:error/message {:en "should be true"}}
'zero? {:error/message {:en "should be zero"}}
#?@(:clj ['rational? {:error/message {:en "should be a rational"}}])
'coll? {:error/message {:en "should be a coll"}}
'empty? {:error/message {:en "should be empty"}}
'associative? {:error/message {:en "should be associative"}}
'sequential? {:error/message {:en "should be sequential"}}
#?@(:clj ['ratio? {:error/message {:en "should be a ratio"}}])
#?@(:clj ['bytes? {:error/message {:en "should be bytes"}}])
:re {:error/message {:en "should match regex"}}
:=> {:error/message {:en "should be a valid function"}}
'ifn? {:error/message {:en "should be an ifn"}}
'fn? {:error/message {:en "should be a fn"}}
:enum {:error/fn {:en (fn [{:keys [schema]} _]
(str "should be "
(if (= 1 (count (m/children schema)))
(-pr-str (first (m/children schema)))
(str "either " (->> (m/children schema) butlast (map -pr-str) (str/join ", "))
" or " (-pr-str (last (m/children schema)))))))}}
:not {:error/fn {:en (fn [{:keys [schema] :as error} options]
(-en-humanize-negation (assoc error :schema (-> schema m/children first)) options))}}
:any {:error/message {:en "should be any"}}
:nil {:error/message {:en "should be nil"}}
:string {:error/fn {:en (fn [{:keys [schema value negated]} _]
(let [{:keys [min max]} (m/properties schema)]
(cond
(not (string? value)) "should be a string"
(and min (= min max)) (str "should be " min " character" (when (not= 1 min) "s"))
(and min ((if negated >= <) (count value) min)) (str "should be at least " min " character"
(when (not= 1 min) "s"))
max (str "should be at most " max " character" (when (not= 1 max) "s"))
negated "should be a string")))}}
:int {:error/fn {:en (-pred-min-max-error-fn {:pred int?, :message "should be an integer"})}}
:double {:error/fn {:en (-pred-min-max-error-fn {:pred double?, :message "should be a double"})}}
:float {:error/fn {:en (-pred-min-max-error-fn {:pred float?, :message "should be a float"})}}
:boolean {:error/message {:en "should be a boolean"}}
:keyword {:error/message {:en "should be a keyword"}}
:symbol {:error/message {:en "should be a symbol"}}
:qualified-keyword {:error/message {:en "should be a qualified keyword"}}
:qualified-symbol {:error/message {:en "should be a qualified symbol"}}
:uuid {:error/message {:en "should be a uuid"}}
:> {:error/fn {:en (fn [{:keys [schema value negated] :as error} options]
(if negated
(-forward-negation [:<= (first (m/children schema))] error options)
(if (number? value)
(str "should be larger than " (first (m/children schema)))
"should be a number")))}}
:>= {:error/fn {:en (fn [{:keys [schema value negated] :as error} options]
(if negated
(-forward-negation [:< (first (m/children schema))] error options)
(if (number? value)
(str "should be at least " (first (m/children schema)))
"should be a number")))}}
:< {:error/fn {:en (fn [{:keys [schema value negated] :as error} options]
(if negated
(-forward-negation [:>= (first (m/children schema))] error options)
(if (number? value)
(str "should be smaller than " (first (m/children schema)))
"should be a number")))}}
:<= {:error/fn {:en (fn [{:keys [schema value negated] :as error} options]
(if negated
(-forward-negation [:> (first (m/children schema))] error options)
(if (number? value)
(str "should be at most " (first (m/children schema)))
"should be a number")))}}
:= {:error/fn {:en (fn [{:keys [schema]} _]
(str "should be " (-pr-str (first (m/children schema)))))}}
:not= {:error/fn {:en (fn [{:keys [schema]} _]
(str "should not be " (-pr-str (first (m/children schema)))))}}})
(defn- -maybe-localized [x locale]
(if (map? x) (get x locale) x))
(defn- -message [error props locale options]
(let [options (or options (m/options (:schema error)))]
(when props (or (when-let [fn (-maybe-localized (:error/fn props) locale)] ((m/eval fn options) error options))
(-maybe-localized (:error/message props) locale)))))
(defn -error [e] ^::error [e])
(defn -error? [x] (-> x meta ::error))
(defn -get [x k] (cond (or (set? x) (associative? x)) (get x k) (sequential? x) (get (vec x) k)))
(defn -concat [x y] (cond->> (concat x y) (and (some? x) (not (seq? x))) (into (empty x))))
(defn -fill [x i fill] (-concat x (repeat (- i (count x)) fill)))
(defn -push [x k v fill]
(let [x' (cond-> x (and (int? k) (sequential? x) (> k (count x))) (-fill k fill))]
(cond (or (nil? x') (associative? x')) (assoc x' k v)
(set? x') (conj x' v)
:else (apply list (assoc (vec x') k v)))))
(defn -push-in [a v [p & ps] e]
(let [v' (-get v p)
a' (or a (cond (sequential? v) [], (record? v) {}, :else (empty v)))]
(cond
;; error present, let's not go deeper
(and p (-error? a')) a
;; we can go deeper
p (-push a' p (-push-in (-get a' p) v' ps e) nil)
;; it's a map!
(map? a) (-push-in a' v [:malli/error] e)
;; accumulate
(-error? a') (conj a' e)
;; lose it
(vector? (not-empty a')) a'
;; first blood
:else (-error e))))
(defn- -path [{:keys [schema]}
{:keys [locale default-locale]
:or {default-locale :en}}]
(let [properties (m/properties schema)]
(or (-maybe-localized (:error/path properties) locale)
(-maybe-localized (:error/path properties) default-locale))))
;;
;; error values
;;
(defn -replace-in [a v [p & ps] e fill]
(let [a' (or a (if (record? v) {} (empty v)))]
(if p (-push (cond-> a' (set? a') (disj p)) p (-replace-in (-get a' p) (-get v p) ps e fill) fill) e)))
(defn -error-value [{:keys [errors value]} options]
(let [mask (::mask-valid-values options)
accept (::accept-error options #(-> % :type (not= ::m/missing-key)))
wrap (::wrap-error options :value)
acc (when (::keep-valid-values options) value)]
(reduce (fn [acc error] (cond-> acc (accept error) (-replace-in value (:in error) (wrap error) mask))) acc errors)))
(defn -masked [mask x y]
(let [nested (and (map? x) (or (map? y) (nil? y)))]
(cond nested (reduce-kv (fn [acc k v] (let [e (find y k)] (assoc acc k (if e (-masked mask v (val e)) mask)))) y x)
(set? x) (cond-> y (not= (count x) (count y)) (conj mask))
(sequential? x) (-fill y (count x) mask)
:else y)))
;;
;; spell checking (kudos to https://github.com/bhauman/spell-spec)
;;
(defn- -length->threshold [len]
(condp #(<= %2 %1) len, 2 0, 5 1, 6 2, 11 3, 20 4 (int (* 0.2 len))))
(defn- -next-row [previous current other-seq]
(reduce
(fn [row [diagonal above other]]
(let [update-val (if (= other current) diagonal (inc (min diagonal above (peek row))))]
(conj row update-val)))
[(inc (first previous))]
(map vector previous (next previous) other-seq)))
(defn- -levenshtein [sequence1 sequence2]
(peek (reduce (fn [previous current] (-next-row previous current sequence2))
(map #(identity %2) (cons nil sequence2) (range))
sequence1)))
(defn- -similar-key [ky ky2]
(let [min-len (apply min (map (m/-comp count #(if (str/starts-with? % ":") (subs % 1) %) str) [ky ky2]))
dist (-levenshtein (str ky) (str ky2))]
(when (<= dist (-length->threshold min-len)) dist)))
(defn- -likely-misspelled [keys known-keys key]
(when-not (known-keys key)
(->> known-keys (filter #(-similar-key % key)) (remove keys) (not-empty))))
(defn -most-similar-to [keys key known-keys]
(->> (-likely-misspelled keys known-keys key)
(map (juxt #(-levenshtein (str %) (str key)) identity))
(filter first)
(sort-by first)
(map second)
(not-empty)))
;;
;; public api
;;
(defn error-path
([error]
(error-path error nil))
([error options]
(into (:in error) (-path error options))))
(defn error-message
([error]
(error-message error nil))
([{:keys [schema type] :as error}
{:keys [errors unknown locale default-locale]
:or {errors default-errors
unknown true
default-locale :en} :as options}]
(or (-message error (m/properties schema) locale options)
(-message error (m/type-properties schema) locale options)
(-message error (errors type) locale options)
(-message error (errors (m/type schema)) locale options)
(-message error (m/properties schema) default-locale options)
(-message error (m/type-properties schema) default-locale options)
(-message error (errors type) default-locale options)
(-message error (errors (m/type schema)) default-locale options)
(and unknown (-message error (errors ::unknown) locale options))
(and unknown (-message error (errors ::unknown) default-locale options)))))
(defn -resolve-direct-error [_ error options]
[(error-path error options) (error-message error options)])
(defn ^:no-doc -resolve-root-error [{:keys [schema]} {:keys [path in] :as error} options]
(let [options (assoc options :unknown false)]
(loop [path path, l nil, mp path, p (m/properties (:schema error)), m (error-message error options)]
(let [[path' m' p'] (or (let [schema (mu/get-in schema path)]
(when-let [m' (error-message {:schema schema} options)] [path m' (m/properties schema)]))
(let [res (and l (mu/find (mu/get-in schema path) l))]
(when (vector? res)
(let [[_ props schema] res
schema (mu/update-properties schema merge props)
message (error-message {:schema schema} options)]
(when message [(conj path l) message (m/properties schema)]))))
(when m [mp m p]))]
(if (seq path)
(recur (pop path) (last path) path' p' m')
(when m [(if (seq in) (mu/path->in schema path') (error-path error options)) m' p']))))))
(defn with-error-message
([error]
(with-error-message error nil))
([error options]
(assoc error :message (error-message error options))))
(defn with-error-messages
([explanation]
(with-error-messages explanation nil))
([explanation {f :wrap :or {f identity} :as options}]
(when explanation
(update explanation :errors (fn [errors] (doall (map #(f (with-error-message % options)) errors)))))))
(defn with-spell-checking
([explanation]
(with-spell-checking explanation nil))
([explanation {:keys [keep-likely-misspelled-of]}]
(when explanation
(let [!likely-misspelling-of (atom #{})
handle-invalid-value (fn [schema _ value]
(let [dispatch (:dispatch (m/properties schema))]
(when (keyword? dispatch)
(let [value (dispatch value)]
[::misspelled-value value #{value}]))))
types {::m/extra-key (fn [_ path value] [::misspelled-key (last path) (-> value keys set (or #{}))])
::m/invalid-dispatch-value handle-invalid-value}]
(update
explanation
:errors
(fn [errors]
(as-> errors $
(mapv (fn [{:keys [schema path type] :as error}]
(if-let [get-keys (types type)]
(let [known-keys (->> schema (m/entries) (map first) (set))
value (get-in (:value explanation) (butlast path))
[error-type key keys] (get-keys schema path value)
similar (-most-similar-to keys key known-keys)
likely-misspelling-of (mapv #(conj (vec (butlast path)) %) (vec similar))]
(swap! !likely-misspelling-of into likely-misspelling-of)
(cond-> error similar (assoc :type error-type
::likely-misspelling-of likely-misspelling-of)))
error)) $)
(if-not keep-likely-misspelled-of
(remove (fn [{:keys [path type]}]
(and (@!likely-misspelling-of path)
(= type ::m/missing-key))) $)
$))))))))
(defn humanize
"Humanized a explanation. Accepts the following options:
- `:wrap`, a function of `error -> message`, defaulting to `:message`
- `:resolve`, a function of `explanation error options -> path message`"
([explanation]
(humanize explanation nil))
([{:keys [value errors] :as explanation} {:keys [wrap resolve]
:or {wrap :message
resolve -resolve-direct-error}
:as options}]
(when errors
(reduce
(fn [acc error]
(let [[path message] (resolve explanation error options)]
(-push-in acc value path (wrap (assoc error :message message)))))
nil errors))))
(defn error-value
"Returns the parts of value that are in error. Accepts the following options:
- `::mask-valid-values`, value to mask valid values with
- `::keep-valid-values`, keep valid values (overrides mask)
- `::accept-error`, function to accept errors
- `::wrap-error`, function to wrap the error map (default: `:value`)"
([explanation]
(error-value explanation nil))
([explanation {mask ::mask-valid-values :as options}]
(cond->> (-error-value explanation options)
mask (-masked mask (:value explanation)))))
malli/src/malli/experimental.cljc
Vendored
+72
View File
@@ -0,0 +1,72 @@
(ns malli.experimental
(:refer-clojure :exclude [defn])
#?(:cljs (:require-macros malli.experimental))
(:require [clojure.core :as c]
[malli.core :as m]
[malli.destructure :as md]))
(c/defn -schema [inline-schemas]
(m/schema
[:schema
{:registry {"Schema" any?
"Separator" (if inline-schemas [:= :-] md/Never)
"Args" [:vector :any]
"PrePost" [:map
[:pre {:optional true} [:sequential any?]]
[:post {:optional true} [:sequential any?]]]
"Arity" [:catn
[:args "Args"]
[:prepost [:? "PrePost"]]
[:body [:* :any]]]
"Params" [:catn
[:name symbol?]
[:return [:? [:catn
[:- "Separator"]
[:schema "Schema"]]]]
[:doc [:? string?]]
[:meta [:? :map]]
[:arities [:altn
[:single "Arity"]
[:multiple [:catn
[:arities [:+ [:schema "Arity"]]]
[:meta [:? :map]]]]]]]}}
"Params"]))
(def SchematizedParams (-schema true))
(def Params (-schema false))
(c/defn -defn [schema args]
(let [{:keys [name return doc arities] body-meta :meta :as parsed} (:values (m/parse schema args))
return (:values return)
var-meta (meta name)
_ (when (= ::m/invalid parsed) (m/-fail! ::parse-error {:schema schema, :args args}))
parse (fn [parsed] (merge (md/parse (-> parsed :values :args)) (:values parsed)))
->schema (fn [{:keys [schema]}] [:=> schema (:schema return :any)])
single (= :single (:key arities))
parglists (if single (->> arities :value parse vector) (->> arities :value :values :arities (map parse)))
raw-arglists (map :raw-arglist parglists)
schema (as-> (map ->schema parglists) $ (if single (first $) (into [:function] $)))
bodies (map (fn [{:keys [arglist prepost body]}] `(~arglist ~prepost ~@body)) parglists)
validate? (or (:malli/always var-meta) (:malli/always body-meta))
enriched-meta (assoc body-meta :raw-arglists (list 'quote raw-arglists) :schema schema)]
`(let [defn# ~(if validate?
`(def
~(with-meta name (merge var-meta
enriched-meta
{:arglists (list 'quote (map :arglist parglists))}))
~@(some-> doc vector)
(m/-instrument {:schema ~schema} (fn ~(gensym (str name "-instrumented")) ~@bodies)))
`(c/defn
~name
~@(some-> doc vector)
~enriched-meta
~@bodies
~@(when-not single (some->> arities :value :meta vector))))]
(m/=> ~name ~schema)
defn#)))
;;
;; public api
;;
#?(:clj (defmacro defn [& args] (-defn SchematizedParams args)))
malli/src/malli/experimental/describe.cljc
Vendored
+265
View File
@@ -0,0 +1,265 @@
(ns malli.experimental.describe
(:require [clojure.string :as str]
[malli.core :as m]))
(declare -describe describe)
(defprotocol Descriptor (-accept [this children options] "transforms schema to a text descriptor"))
(defn -diamond [s] (str "<" s ">"))
(defn -titled [schema] (if-let [t (-> schema m/properties :title)] (str "(titled: ‘" t "’) ") ""))
(defn -min-max-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)]
(cond
(and min max) (str " between " min " and " max " inclusive")
min (str " greater than " min)
max (str " less than " max)
:else "")))
(defn -length-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)]
(cond
(and min max) (str " with length between " min " and " max " inclusive")
min (str " with length >= " min)
max (str " with length <= " max)
:else "")))
(defn -pluralize-times [n]
(when n
(if (= 1 n) "time" "times")))
(defn -repeat-suffix [schema]
(let [{:keys [min max]} (-> schema m/properties)
min-timez (-pluralize-times min)
max-timez (-pluralize-times max)]
(cond
(and min max) (str " at least " min " " min-timez ", up to " max " " max-timez)
min (str " at least " min " " min-timez)
max (str " at most " max " " max-timez)
:else "")))
(defn -min-max-suffix-number [schema]
(let [{:keys [min max]} (-> schema m/properties)]
(cond
(and min max) (str " between " min " and " max " inclusive")
min (str " greater than or equal to " min)
max (str " less than or equal to " max)
:else "")))
(defmulti accept "Can this be accepted?" (fn [name _schema _children _options] name) :default ::default)
(defmethod accept ::default [name schema children {:keys [missing-fn]}] (if missing-fn (missing-fn name schema children) ""))
(defn -schema [schema children _options]
(let [just-one (= 1 (count (:registry (m/properties schema))))]
(str (or (m/-ref schema) (last children))
(when (:registry (m/properties schema))
(str " "
(when-not just-one "which is: ")
(-diamond (str/join ", " (for [[name schema] (:registry (m/properties schema))]
(str (when-not just-one (str name " is "))
(describe schema))))))))))
(defmethod accept :schema [_ schema children options] (-schema schema children options))
(defmethod accept ::m/schema [_ schema children options] (-schema schema children options))
(defmethod accept :ref [_ _schema children _] (pr-str (first children)))
(defmethod accept 'ident? [_ _ _ _] "ident")
(defmethod accept 'simple-ident? [_ _ _ _] "simple-ident")
(defmethod accept 'uuid? [_ _ _ _] "uuid")
(defmethod accept 'uri? [_ _ _ _] "uri")
(defmethod accept 'decimal? [_ _ _ _] "decimal")
(defmethod accept 'inst? [_ _ _ _] "inst (aka date time)")
(defmethod accept 'seqable? [_ _ _ _] "seqable")
(defmethod accept 'indexed? [_ _ _ _] "indexed")
(defmethod accept 'vector? [_ _ _ _] "vector")
(defmethod accept 'list? [_ _ _ _] "list")
(defmethod accept 'seq? [_ _ _ _] "seq")
(defmethod accept 'char? [_ _ _ _] "char")
(defmethod accept 'set? [_ _ _ _] "set")
(defmethod accept 'false? [_ _ _ _] "false")
(defmethod accept 'true? [_ _ _ _] "true")
(defmethod accept 'zero? [_ _ _ _] "zero")
#?(:clj (defmethod accept 'rational? [_ _ _ _] "rational"))
(defmethod accept 'coll? [_ _ _ _] "collection")
(defmethod accept 'empty? [_ _ _ _] "empty")
(defmethod accept 'associative? [_ _ _ _] "is associative")
#?(:clj (defmethod accept 'ratio? [_ _ _ _] "ratio"))
(defmethod accept 'bytes? [_ _ _ _] "bytes")
(defmethod accept 'ifn? [_ _ _ _] "implmenets IFn")
(defmethod accept 'fn? [_ _ _ _] "function")
(defmethod accept :> [_ _ [value] _] (str "> " value))
(defmethod accept :>= [_ _ [value] _] (str ">= " value))
(defmethod accept :< [_ _ [value] _] (str "< " value))
(defmethod accept :<= [_ _ [value] _] (str "<= " value))
(defmethod accept := [_ _ [value] _] (str "must equal " value))
(defmethod accept :not= [_ _ [value] _] (str "not equal " value))
(defmethod accept :not [_ _ children _] {:not (last children)})
(defmethod accept :multi [_ s children _]
(let [dispatcher (or (-> s m/properties :dispatch-description)
(-> s m/properties :dispatch))]
(str "one of "
(-diamond
(str/join " | " (map (fn [[title _ shape]] (str title " = " shape)) children)))
" dispatched by " dispatcher)))
(defmethod accept :map-of [_ schema children _]
(str "map " (-titled schema) "from " (-diamond (first children)) " to " (-diamond (second children)) (-length-suffix schema)))
(defn -of-clause [children] (when children (str " of " (first children))))
(defmethod accept 'vector? [_ schema children _] (str "vector" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod accept :vector [_ schema children _] (str "vector" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod accept 'sequential? [_ schema children _] (str "sequence" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod accept :sequential [_ schema children _] (str "sequence" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod accept 'set? [_ schema children _] (str "set" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod accept :set [_ schema children _] (str "set" (-titled schema) (-length-suffix schema) (-of-clause children)))
(defmethod accept 'string? [_ schema _ _] (str "string" (-titled schema) (-length-suffix schema)))
(defmethod accept :string [_ schema _ _] (str "string" (-titled schema) (-length-suffix schema)))
(defmethod accept 'number? [_ schema _ _] (str "number" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :number [_ schema _ _] (str "number" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'pos-int? [_ schema _ _] (str "integer greater than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :pos-int [_ schema _ _] (str "integer greater than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'neg-int? [_ schema _ _] (str "integer less than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :neg-int [_ schema _ _] (str "integer less than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'nat-int? [_ schema _ _] (str "natural integer" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :nat-int [_ schema _ _] (str "natural integer" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'float? [_ schema _ _] (str "float" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :float [_ schema _ _] (str "float" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'pos? [_ schema _ _] (str "number greater than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :pos [_ schema _ _] (str "number greater than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'neg? [_ schema _ _] (str "number less than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept :neg [_ schema _ _] (str "number less than 0" (-titled schema) (-min-max-suffix schema)))
(defmethod accept 'integer? [_ schema _ _] (str "integer" (-titled schema) (-min-max-suffix-number schema)))
(defmethod accept 'int? [_ schema _ _] (str "integer" (-titled schema) (-min-max-suffix-number schema)))
(defmethod accept :int [_ schema _ _] (str "integer" (-titled schema) (-min-max-suffix-number schema)))
(defmethod accept 'double? [_ schema _ _] (str "double" (-titled schema) (-min-max-suffix-number schema)))
(defmethod accept :double [_ schema _ _] (str "double" (-titled schema) (-min-max-suffix-number schema)))
(defmethod accept :merge [_ schema _ {::keys [describe] :as options}] (describe (m/deref schema) options))
(defmethod accept :union [_ schema _ {::keys [describe] :as options}] (describe (m/deref schema) options))
(defmethod accept :select-keys [_ schema _ {::keys [describe] :as options}] (describe (m/deref schema) options))
(defn -tagged [children] (map (fn [[tag _ c]] (str c " (tag: " tag ")")) children))
(defmethod accept :and [_ s children _] (str (str/join ", and " children) (-titled s)))
(defmethod accept :andn [_ s children _] (str (str/join ", and " (-tagged children)) (-titled s)))
(defmethod accept :enum [_ s children _options] (str "enum" (-titled s) " of " (str/join ", " children)))
(defmethod accept :maybe [_ s children _] (str "nullable " (-titled s) (first children)))
(defmethod accept :tuple [_ s children _] (str "vector " (-titled s) "with exactly " (count children) " items of type: " (str/join ", " children)))
(defmethod accept :re [_ s _ options] (str "regex pattern " (-titled s) "matching " (pr-str (first (m/children s options)))))
(defmethod accept 'any? [_ s _ _] (str "anything" (-titled s)))
(defmethod accept :any [_ s _ _] (str "anything" (-titled s)))
(defmethod accept 'some? [_ _ _ _] "anything but null")
(defmethod accept :some [_ _ _ _] "anything but null")
(defmethod accept 'nil? [_ _ _ _] "null")
(defmethod accept :nil [_ _ _ _] "null")
(defmethod accept 'qualified-ident? [_ _ _ _] "qualified-ident")
(defmethod accept :qualified-ident [_ _ _ _] "qualified-ident")
(defmethod accept 'simple-keyword? [_ _ _ _] "simple-keyword")
(defmethod accept :simple-keyword [_ _ _ _] "simple-keyword")
(defmethod accept 'simple-symbol? [_ _ _ _] "simple-symbol")
(defmethod accept :simple-symbol [_ _ _ _] "simple-symbol")
(defmethod accept 'qualified-keyword? [_ _ _ _] "qualified-keyword")
(defmethod accept :qualified-keyword [_ _ _ _] "qualified keyword")
(defmethod accept 'symbol? [_ _ _ _] "symbol")
(defmethod accept :symbol [_ _ _ _] "symbol")
(defmethod accept 'qualified-symbol? [_ _ _ _] "qualified-symbol")
(defmethod accept :qualified-symbol [_ _ _ _] "qualified symbol")
(defmethod accept :uuid [_ _ _ _] "uuid")
(defn -accept-=> [s]
(let [{:keys [input output]} (m/-function-info s)]
(str "function that takes input: [" (describe input) "] and returns " (describe output))))
(defmethod accept :=> [_ s _ _] (-accept-=> s))
(defmethod accept :-> [_ s _ _] (-accept-=> s))
(defmethod accept :function [_ _ _children _] "function")
(defmethod accept :fn [_ _ _ _] "function")
(defmethod accept :or [_ _ children _] (str/join ", or " children))
(defmethod accept :orn [_ _ children _] (str/join ", or " (-tagged children)))
(defmethod accept :cat [_ _ children _] (str/join ", " children))
(defmethod accept :catn [_ _ children _] (str/join ", and " (-tagged children)))
(defmethod accept :alt [_ _ children _] (str/join ", or " children))
(defmethod accept :altn [_ _ children _] (str/join ", or " (-tagged children)))
(defmethod accept :+ [_ _ children _] (str "one or more " (str/join ", " children)))
(defmethod accept :* [_ _ children _] (str "zero or more " (str/join ", " children)))
(defmethod accept :? [_ _ children _] (str "zero or one " (str/join ", " children)))
(defmethod accept :repeat [_ schema children _]
(str "repeat " (-diamond (first children)) (-repeat-suffix schema)))
(defmethod accept 'boolean? [_ _ _ _] "boolean")
(defmethod accept :boolean [_ _ _ _] "boolean")
(defmethod accept 'keyword? [_ _ _ _] "keyword")
(defmethod accept :keyword [_ _ _ _] "keyword")
(defn -map [_n schema children _o]
(let [optional (set (->> children (filter (m/-comp :optional second)) (mapv first)))
additional-properties (:closed (m/properties schema))
kv-description (str/join ", " (map (fn [[k _ s]] (str k (when (contains? optional k) " (optional)") " -> " (-diamond s))) children))]
(str/trim
(cond-> (str "map " (-titled schema))
(seq kv-description) (str "where {" kv-description "} ")
additional-properties (str "with no other keys ")))))
(defmethod accept ::m/val [_ _ children _] (first children))
(defmethod accept 'map? [n schema children o] (-map n schema children o))
(defmethod accept :map [n schema children o] (-map n schema children o))
(defn -descriptor-walker [schema _ children options]
(let [p (merge (m/type-properties schema) (m/properties schema))]
(or (get p :description)
(if (satisfies? Descriptor schema)
(-accept schema children options)
(accept (m/type schema) schema children options)))))
(defn -describe [?schema options]
(m/walk ?schema -descriptor-walker options))
;;
;; public api
;;
(defn describe
"Given a schema, returns a string explaining the required shape in English"
([?schema]
(describe ?schema nil))
([?schema options]
(let [definitions (atom {})
options (merge options
{::m/walk-entry-vals true,
::definitions definitions,
::describe -describe})]
(str/trim (-describe ?schema options)))))
malli/src/malli/experimental/lite.cljc
Vendored
+23
View File
@@ -0,0 +1,23 @@
(ns malli.experimental.lite
(:refer-clojure :exclude [set vector and or])
(:require [malli.core :as m]))
(declare schema)
(def ^:dynamic *options* nil)
(defrecord -Optional [value])
(defn -schema [t & xs] (schema (into [t] (map schema xs))))
(defn -entry [[k v]]
(let [[v optional] (if (instance? -Optional v) [(:value v) true] [v])]
(cond-> [k] optional (conj {:optional true}) :always (conj (schema v)))))
(defn schema [x] (m/schema (if (map? x) (into [:map] (map -entry x)) x) *options*))
(defn optional [x] (->-Optional x))
(defn maybe [x] (-schema :maybe x))
(defn set [x] (-schema :set x))
(defn vector [x] (-schema :vector x))
(defn map-of [k v] (-schema :map-of k v))
(defn tuple [& xs] (apply -schema :tuple xs))
(defn and [& xs] (apply -schema :and xs))
(defn or [& xs] (apply -schema :or xs))
malli/src/malli/experimental/time.cljc
Vendored
+108
View File
@@ -0,0 +1,108 @@
(ns malli.experimental.time
(:refer-clojure :exclude [<=])
(:require [malli.core :as m]
#?(:cljs ["@js-joda/core" :as js-joda]))
#?(:clj (:import (java.time Duration Period LocalDate LocalDateTime LocalTime Instant ZonedDateTime OffsetDateTime ZoneId OffsetTime ZoneOffset))))
#?(:cljs
(do
(def Period (.-Period js-joda))
(def Instant (.-Instant js-joda))
(def Duration (.-Duration js-joda))
(def LocalDate (.-LocalDate js-joda))
(def LocalTime (.-LocalTime js-joda))
(def ZonedDateTime (.-ZonedDateTime js-joda))
(def LocalDateTime (.-LocalDateTime js-joda))
(def MonthDay (.-MonthDay js-joda))
(def Year (.-Year js-joda))
(def YearMonth (.-YearMonth js-joda))
(def ZoneId (.-ZoneId js-joda))
(def DayOfWeek (.-DayOfWeek js-joda))
(def Month (.-Month js-joda))
(def Clock (.-Clock js-joda))
(def ZoneOffset (.-ZoneOffset js-joda))
(def OffsetDateTime (.-OffsetDateTime js-joda))
(def OffsetTime (.-OffsetTime js-joda))
(def TemporalAccessor (.-TemporalAccessor js-joda))
(def TemporalQuery (.-TemporalQuery js-joda))
(def DateTimeFormatter (.-DateTimeFormatter js-joda))))
(defn <= [^Comparable x ^Comparable y] (not (pos? (.compareTo x y))))
(defn compare-periods
"Periods are not comparable in the java Comparable sense, instead this performs simple units-by-units comparison.
So a period of 1 year will always compare greater than a period of 13 months and similar for days and months."
[^Period p1 ^Period p2]
(let [years1 #?(:clj (.getYears p1) :cljs (.years p1))
years2 #?(:clj (.getYears p2) :cljs (.years p2))
months1 #?(:clj (.getMonths p1) :cljs (.months p1))
months2 #?(:clj (.getMonths p2) :cljs (.months p2))
days1 #?(:clj (.getDays p1) :cljs (.days p1))
days2 #?(:clj (.getDays p2) :cljs (.days p2))]
(cond
(not (= years1 years2)) (- years1 years2)
(not (= months1 months2)) (- months1 months2)
:else (- days1 days2))))
(defn -min-max-pred [_]
(fn [{:keys [min max]}]
(cond
(not (or min max)) nil
(and min max)
(if (and (instance? Period min) (instance? Period max))
(fn [^Period x]
(and
(not (pos? (compare-periods x max)))
(not (pos? (compare-periods min x)))))
(fn [x] (and (<= x max) (<= min x))))
min (fn [x]
(if (instance? Period min)
(not (pos? (compare-periods min x)))
(<= min x)))
max (fn [x]
(if (instance? Period max)
(not (pos? (compare-periods x max)))
(<= x max))))))
(defn -temporal-schema [{:keys [type class type-properties]}]
(m/-simple-schema
(cond->
{:type type
:pred (fn pred [x]
#?(:clj (.isInstance ^Class class x)
:cljs (instance? class x)))
:property-pred (-min-max-pred nil)}
type-properties
(assoc :type-properties type-properties))))
#?(:cljs
(defn createTemporalQuery [f]
(let [parent (TemporalQuery. "")
query (js/Object.create parent)]
(set! (.-queryFrom query) (fn [t] (f t)))
query)))
(defn -duration-schema [] (-temporal-schema {:type :time/duration :class Duration}))
(defn -period-schema [] (-temporal-schema {:type :time/period :class Period}))
(defn -instant-schema [] (-temporal-schema {:type :time/instant :class Instant}))
(defn -local-date-schema [] (-temporal-schema {:type :time/local-date :class LocalDate :type-properties {:min (. LocalDate -MIN) :max (. LocalDate -MAX)}}))
(defn -local-time-schema [] (-temporal-schema {:type :time/local-time :class LocalTime :type-properties {:min (. LocalTime -MIN) :max (. LocalTime -MAX)}}))
(defn -local-date-time-schema [] (-temporal-schema {:type :time/local-date-time :class LocalDateTime :type-properties {:min (. LocalDateTime -MIN) :max (. LocalDateTime -MAX)}}))
(defn -offset-date-time-schema [] (-temporal-schema {:type :time/offset-date-time :class OffsetDateTime}))
(defn -offset-time-schema [] (-temporal-schema {:type :time/offset-time :class OffsetTime :type-properties {:min (. OffsetTime -MIN) :max (. OffsetTime -MAX)}}))
(defn -zoned-date-time-schema [] (-temporal-schema {:type :time/zoned-date-time :class ZonedDateTime}))
(defn -zone-id-schema [] (m/-simple-schema {:type :time/zone-id :pred #(instance? ZoneId %)}))
(defn -zone-offset-schema [] (m/-simple-schema {:type :time/zone-offset :pred #(instance? ZoneOffset %) :type-properties {:min (. ZoneOffset -MIN) :max (. ZoneOffset -MAX)}}))
(defn schemas []
{:time/zone-id (-zone-id-schema)
:time/instant (-instant-schema)
:time/duration (-duration-schema)
:time/period (-period-schema)
:time/zoned-date-time (-zoned-date-time-schema)
:time/offset-date-time (-offset-date-time-schema)
:time/local-date (-local-date-schema)
:time/local-time (-local-time-schema)
:time/offset-time (-offset-time-schema)
:time/zone-offset (-zone-offset-schema)
:time/local-date-time (-local-date-time-schema)})
malli/src/malli/experimental/time/generator.cljc
Vendored
+156
View File
@@ -0,0 +1,156 @@
(ns malli.experimental.time.generator
(:require [clojure.test.check.generators :as gen]
[clojure.spec.gen.alpha :as ga]
[malli.core :as m]
[malli.generator :as mg]
#?(:clj [malli.experimental.time :as time]
:cljs [malli.experimental.time :as time
:refer [Duration Period LocalDate LocalDateTime LocalTime Instant OffsetTime ZonedDateTime OffsetDateTime ZoneId ZoneOffset]]))
#?(:clj (:import (java.time Duration Period LocalDate LocalDateTime LocalTime Instant OffsetTime ZonedDateTime OffsetDateTime ZoneId ZoneOffset))))
#?(:clj (set! *warn-on-reflection* true))
(defn zone-id-gen []
(mg/generator (m/into-schema (m/-enum-schema) nil (map #(. ZoneId of ^String %) (. ZoneId getAvailableZoneIds)))))
(defmethod mg/-schema-generator :time/zone-id [_schema _options] (zone-id-gen))
#?(:clj (def ^:const ^:private seconds-in-day 86400)
:cljs (def ^:private seconds-in-day 86400))
(defn -to-long ^long [o]
(cond
(instance? Instant o) (.toEpochMilli ^Instant o)
(instance? LocalDate o) (.toEpochDay ^LocalDate o)
(instance? LocalTime o) (.toSecondOfDay ^LocalTime o)
(instance? ZoneOffset o) #?(:clj (.getTotalSeconds ^ZoneOffset o)
:cljs (.totalSeconds ^ZoneOffset o))
(instance? LocalDateTime o)
(unchecked-add
(unchecked-multiply (.toEpochDay (.toLocalDate ^LocalDateTime o)) seconds-in-day)
(-to-long (.toLocalTime ^LocalDateTime o)))
(instance? OffsetDateTime o) (.toEpochMilli (.toInstant ^OffsetDateTime o))
(instance? ZonedDateTime o) (.toEpochMilli (.toInstant ^ZonedDateTime o))
(instance? Duration o) (.toNanos ^Duration o)
(int? o) (long o)))
(defn to-long [o] (when o (-to-long o)))
(defn -min-max [schema options]
(let [{:keys [min max] gen-min :gen/min gen-max :gen/max}
(merge
(m/type-properties schema options)
(m/properties schema options))
{:keys [accessor] :or {accessor identity}} options
as-long #(when % (to-long (accessor %)))
min (as-long min) max (as-long max) gen-min (as-long gen-min) gen-max (as-long gen-max)]
(when (and min gen-min (< gen-min min))
(m/-fail! ::mg/invalid-property {:key :gen/min, :value gen-min, :min min}))
(when (and max gen-max (> gen-max max))
(m/-fail! ::mg/invalid-property {:key :gen/max, :value gen-min, :max min}))
{:min (or gen-min min)
:max (or gen-max max)}))
(defn -zone-offset-gen [schema options]
(ga/fmap #(. ZoneOffset ofTotalSeconds %) (gen/large-integer* (-min-max schema options))))
(defmethod mg/-schema-generator :time/zone-offset [schema options]
(-zone-offset-gen schema options))
(defn -instant-gen [schema options]
(ga/fmap #(. Instant ofEpochMilli %) (gen/large-integer* (-min-max schema options))))
(defmethod mg/-schema-generator :time/instant [schema options]
(-instant-gen schema options))
(comment
(gen/sample (mg/-schema-generator (time/-instant-schema) nil)))
(defmethod mg/-schema-generator :time/local-date [schema options]
(ga/fmap #(. LocalDate ofEpochDay %) (gen/large-integer* (-min-max schema options))))
(defn -local-time-gen [schema options]
(ga/fmap #(. LocalTime ofSecondOfDay %) (gen/large-integer* (-min-max schema options))))
(defmethod mg/-schema-generator :time/local-time [schema options]
(-local-time-gen schema options))
(comment
(gen/sample (mg/-schema-generator (time/-local-time-schema) nil)))
(defn -offset-time-gen [schema options]
(let [local-opts (assoc options :accessor #(.toLocalTime ^OffsetTime %))
zone-opts #?(:clj (assoc options :accessor #(- (.getTotalSeconds (.getOffset ^OffsetTime %))))
:cljs (assoc options :accessor #(- (.totalSeconds (.offset ^js %)))))
offset-gen (-zone-offset-gen schema zone-opts)]
(ga/bind
(-local-time-gen schema local-opts)
(fn [local-time]
(ga/fmap #(. OffsetTime of local-time %) offset-gen)))))
(defmethod mg/-schema-generator :time/offset-time [schema options]
(-offset-time-gen schema options))
(comment
(gen/sample (mg/-schema-generator (time/-offset-time-schema) nil)))
(defmethod mg/-schema-generator :time/local-date-time [schema options]
(gen/fmap
(fn [n]
(. LocalDateTime of
(. LocalDate ofEpochDay (quot n seconds-in-day))
(. LocalTime ofSecondOfDay (mod n seconds-in-day))))
(gen/large-integer* (-min-max schema options))))
(comment
(gen/sample (mg/-schema-generator (time/-local-date-time-schema) nil) 1000))
(defn -zoned-date-time-gen [schema options]
(gen/bind
(-instant-gen schema options)
(fn [instant]
(gen/fmap #(. ZonedDateTime ofInstant instant %) (zone-id-gen)))))
(defmethod mg/-schema-generator :time/zoned-date-time [schema options]
(-zoned-date-time-gen schema options))
(comment
(gen/sample (mg/-schema-generator (time/-zoned-date-time-schema) nil) 100))
(defn -offset-date-time-gen [schema options]
(gen/fmap #(. OffsetDateTime from %) (-zoned-date-time-gen schema options)))
(defmethod mg/-schema-generator :time/offset-date-time [schema options]
(-offset-date-time-gen schema options))
(defmethod mg/-schema-generator :time/duration [schema options]
(gen/fmap #(. Duration ofNanos %) (gen/large-integer* (-min-max schema options))))
;; Years, Months, Days of periods are never nil, they just return zero, so we treat zero as nil.
(defmethod mg/-schema-generator :time/period [schema options]
(let [zero->nil (fn [v] (if (zero? v) nil v))
max-int #?(:clj Integer/MAX_VALUE :cljs (.-MAX_SAFE_INTEGER js/Number))
min-int #?(:clj Integer/MIN_VALUE :cljs (.-MIN_SAFE_INTEGER js/Number))
ceil-max (fn [v] (if (nil? v) max-int (min max-int v)))
floor-min (fn [v] (if (nil? v) min-int (max min-int v)))
{^Period mn :min ^Period mx :max ^Period gen-min :gen/min ^Period gen-max :gen/max}
(merge
(m/type-properties schema options)
(m/properties schema options))
_ (when (and mn gen-min (not (pos? (time/compare-periods gen-min min))))
(m/-fail! ::mg/invalid-property {:key :gen/min, :value gen-min, :min min}))
_ (when (and mx gen-max (not (pos? (time/compare-periods max gen-max))))
(m/-fail! ::mg/invalid-property {:key :gen/max, :value gen-min, :max min}))
mn (or mn gen-min)
mx (or mx gen-max)
min-years (when mn (zero->nil (.getYears mn))), max-years (when mx (zero->nil (.getYears mx)))
min-months (when mn (zero->nil (.getMonths mn))), max-months (when mx (zero->nil (.getMonths mx)))
min-days (when mn (zero->nil (.getDays mn))), max-days (when mx (zero->nil (.getDays mx)))]
(->>
(gen/tuple
;; Period constructor only accepts java type `int` not `long`, clamp the values
(gen/large-integer* {:min (floor-min min-years) :max (ceil-max max-years)})
(gen/large-integer* {:min (floor-min min-months) :max (ceil-max max-months)})
(gen/large-integer* {:min (floor-min min-days) :max (ceil-max max-days)}))
(gen/fmap (fn [[years months days]]
(. Period of years months days))))))
malli/src/malli/experimental/time/json_schema.cljc
Vendored
+57
View File
@@ -0,0 +1,57 @@
(ns malli.experimental.time.json-schema
(:require [malli.experimental.time]
[malli.json-schema :as json]))
;; date-time: A string instance is valid against this attribute if it is
;; a valid representation according to the "date-time' ABNF rule
;; (referenced above)
;; date: A string instance is valid against this attribute if it is a
;; valid representation according to the "full-date" ABNF rule
;; (referenced above)
;; time: A string instance is valid against this attribute if it is a
;; valid representation according to the "full-time" ABNF rule
;; (referenced above)
;; duration: A string instance is valid against this attribute if it is
;; a valid representation according to the "duration" ABNF rule
;; (referenced above)
;; Implementations MAY support additional attributes using the other
;; format names defined anywhere in that RFC. If "full-date" or
;; "full-time" are implemented, the corresponding short form ("date" or
;; "time" respectively) MUST be implemented, and MUST behave
;; identically. Implementations SHOULD NOT define extension attributes
;; with any name matching an RFC 3339 format unless it validates
;; according to the rules of that format. There is not currently
;; consensus on the need for supporting all RFC 3339 formats, so this
;; approach of reserving the namespace will encourage experimentation
;; without committing to the entire set. Either the format
;; implementation requirements will become more flexible in general, or
;; these will likely either be promoted to fully specified attributes or
;; dropped.
;; date-fullyear = 4DIGIT
;; date-month = 2DIGIT ; 01-12
;; date-mday = 2DIGIT ; 01-28, 01-29, 01-30, 01-31 based on
;; ; month/year
;; time-hour = 2DIGIT ; 00-23
;; time-minute = 2DIGIT ; 00-59
;; time-second = 2DIGIT ; 00-58, 00-59, 00-60 based on leap second
;; ; rules
;; time-secfrac = "." 1*DIGIT
;; time-numoffset = ("+" / "-") time-hour ":" time-minute
;; time-offset = "Z" / time-numoffset
;; partial-time = time-hour ":" time-minute ":" time-second
;; [time-secfrac]
;; full-date = date-fullyear "-" date-month "-" date-mday
;; full-time = partial-time time-offset
;; date-time = full-date "T" full-time
(defmethod json/accept :time/local-date [_ _ _ _] {:type "string" :format "date"})
(defmethod json/accept :time/offset-time [_ _ _ _] {:type "string" :format "time"})
(defmethod json/accept :time/offset-date-time [_ _ _ _] {:type "string" :format "date-time"})
(defmethod json/accept :time/duration [_ _ _ _] {:type "string" :format "duration"})
malli/src/malli/experimental/time/transform.cljc
Vendored
+109
View File
@@ -0,0 +1,109 @@
(ns malli.experimental.time.transform
(:require [malli.transform :as mt :refer [-safe]]
[malli.core :as m]
#?(:cljs [malli.experimental.time :as time
:refer [Duration Period LocalDate LocalDateTime LocalTime Instant OffsetTime ZonedDateTime OffsetDateTime ZoneId ZoneOffset
TemporalAccessor TemporalQuery DateTimeFormatter createTemporalQuery]]))
#?(:clj
(:import (java.time Duration Period LocalDate LocalDateTime LocalTime Instant ZonedDateTime OffsetDateTime ZoneId OffsetTime ZoneOffset)
(java.time.temporal TemporalAccessor TemporalQuery)
(java.time.format DateTimeFormatter))))
#?(:clj (set! *warn-on-reflection* true))
#?(:clj
(defn ->temporal-query ^TemporalQuery [f]
(reify TemporalQuery
(queryFrom [_ t]
(f t))))
:cljs
(defn ->temporal-query ^TemporalQuery [f]
(createTemporalQuery f)))
(defn ->parser [formatter qf]
(let [query (->temporal-query qf)]
(fn [#?(:clj ^CharSequence s :cljs s)]
(if #?(:clj (instance? CharSequence s) :cljs (string? s))
(.parse ^DateTimeFormatter formatter s query)
s))))
(defn ->formatter [x]
(cond
(instance? DateTimeFormatter x) x
#?(:clj (instance? String x)
:cljs (string? x)) (. DateTimeFormatter ofPattern x)
:else (throw (ex-info "Invalid formatter" {:formatter x :type (type x)}))))
(def default-formats
{:time/instant (. DateTimeFormatter -ISO_INSTANT)
:time/local-date (. DateTimeFormatter -ISO_LOCAL_DATE)
:time/local-date-time (. DateTimeFormatter -ISO_LOCAL_DATE_TIME)
:time/local-time (. DateTimeFormatter -ISO_LOCAL_TIME)
:time/offset-time (. DateTimeFormatter -ISO_OFFSET_TIME)
:time/offset-date-time (. DateTimeFormatter -ISO_OFFSET_DATE_TIME)
:time/zoned-date-time (. DateTimeFormatter -ISO_ZONED_DATE_TIME)})
(def queries
{:time/instant #(. Instant from %)
:time/local-time #(. LocalTime from %)
:time/local-date #(. LocalDate from %)
:time/local-date-time #(. LocalDateTime from %)
:time/offset-date-time #(. OffsetDateTime from %)
:time/offset-time #(. OffsetTime from %)
:time/zoned-date-time #(. ZonedDateTime from %)})
(def default-parsers
(reduce-kv
(fn [m k v] (assoc m k (-safe (->parser v (get queries k)))))
{:time/duration (-safe #(. Duration parse %))
:time/period (-safe #(. Period parse %))
:time/zone-offset (-safe #(. ZoneOffset of ^String %))
:time/zone-id (-safe #(. ZoneId of %))}
default-formats))
(defn compile-parser [type formatter pattern]
(when-let [formatter (when-let [x (or formatter pattern)]
(->formatter x))]
(-safe (->parser formatter (get queries type)))))
(defn time-decoders [formats]
(into
default-parsers
(for [k (keys formats)]
[k {:compile
(fn [schema opts]
(let [t (m/type schema opts)
{:keys [formatter pattern]} (m/properties schema)]
(or (compile-parser t formatter pattern)
(get default-parsers t))))}])))
(defn time-encoders [formats]
(into
{:time/duration #?(:clj (-safe (fn [^Duration d]
(if (instance? Duration d) (str d) d)))
:cljs #(when % (str %)))
:time/period #?(:clj (-safe (fn [^Period p]
(if (instance? Period p) (str p) p)))
:cljs #(when % (str %)))
:time/zone-id #?(:clj (-safe (fn [^ZoneId z]
(if (instance? ZoneId z) (str z) z)))
:cljs #(when % (str %)))}
(for [k (keys formats)]
[k {:compile
(fn [schema opts]
(let [t (m/type schema opts)
{:keys [formatter pattern]} (m/properties schema)
formatter (->formatter (or formatter pattern (get default-formats t)))]
(-safe
(fn [^TemporalAccessor ta]
(if (instance? TemporalAccessor ta)
(.format ^DateTimeFormatter formatter ta)
ta)))))}])))
(defn time-transformer
([] (time-transformer default-formats))
([formats]
(mt/transformer
{:name :time
:decoders (time-decoders formats)
:encoders (time-encoders formats)})))
malli/src/malli/experimental/validate.cljc
Vendored
+59
View File
@@ -0,0 +1,59 @@
(ns malli.experimental.validate
"Experimental :validate schema that allows outputting custom errors."
(:require [malli.core :as m]
[malli.impl.util :as miu]))
;; This is mostly a copy of -fn-schema. If we decide to move
;; -validate-schema to the core, it could be a couple of branches
;; inside -fn-schema.
(defn -validate-schema []
^{:type ::into-schema}
(reify
m/AST
(-from-ast [parent ast options] (m/-from-value-ast parent ast options))
m/IntoSchema
(-type [_] :fn)
(-type-properties [_])
(-into-schema [parent properties children options]
(m/-check-children! :fn properties children 1 1)
(let [children (vec children)
f (m/eval (first children) options)
form (delay (m/-simple-form parent properties children identity options))
cache (m/-create-cache options)]
^{:type ::schema}
(reify
m/AST
(-to-ast [this _] (m/-to-value-ast this))
m/Schema
(-validator [_] (m/-safe-pred (fn [val] (nil? (f val)))))
(-explainer [this path]
(fn explain [x in0 acc]
(try
(if-let [errors (seq (f x))]
(into acc (map (fn [{:keys [in type value]}] (miu/-error path (into in0 in) this value type))) errors)
acc)
(catch #?(:clj Exception, :cljs js/Error) e
(conj acc (miu/-error path in0 this x (:type (ex-data e))))))))
(-parser [this] (m/-simple-parser this))
(-unparser [this] (m/-parser this))
(-transformer [this transformer method options]
(m/-intercepting (m/-value-transformer transformer this method options)))
(-walk [this walker path options] (m/-walk-leaf this walker path options))
(-properties [_] properties)
(-options [_] options)
(-children [_] children)
(-parent [_] parent)
(-form [_] @form)
m/Cached
(-cache [_] cache)
m/LensSchema
(-keep [_])
(-get [_ key default] (get children key default))
(-set [this key value] (m/-set-assoc-children this key value))
m/ParserInfo
(-parser-info [_ _] {:simple-parser true})
#?@(:cljs [IPrintWithWriter (-pr-writer [this writer opts] (m/-pr-writer-schema this writer opts))]))))
#?@(:cljs [IPrintWithWriter (-pr-writer [this writer opts] (m/-pr-writer-into-schema this writer opts))])))
(defn schemas []
{:validate (-validate-schema)})
malli/src/malli/generator.cljc
Vendored
+562
View File
@@ -0,0 +1,562 @@
;; See also `malli.generator-ast` for viewing generators as data
(ns malli.generator
(:require [clojure.set :as set]
[clojure.spec.gen.alpha :as ga]
[clojure.string :as str]
[clojure.test.check :as check]
[clojure.test.check.generators :as gen]
[clojure.test.check.properties :as prop]
[clojure.test.check.random :as random]
[clojure.test.check.rose-tree :as rose]
[malli.core :as m]
[malli.registry :as mr]
[malli.util :as mu]
[malli.impl.util :refer [-last -merge]]
#?(:clj [borkdude.dynaload :as dynaload])))
(declare generator generate -create gen-one-of gen-double)
(defprotocol Generator
(-generator [this options] "returns generator for schema"))
;;
;; generators
;;
;; # Notes for implementors
;;
;; For the most part, -schema-generator is a pretty direct translation from schemas to generators.
;; However, the naive implementation of recursive ref's (creating a generator for the dereferenced ref
;; and cutting off the generation at a certain depth) tends to create exponentially large test cases.
;;
;; We use a more sophisticated algorithm to achieve linearly sized test cases with recursive refs.
;; The next section describes the strategy implementors should use to participate in this improved behavior.
;; The theory behind this strategy is described in the section below ("Approach for recursive generators").
;;
;; ## Implementation strategy
;;
;; Say you have a composite schema you want to generate values for. You should extend `-schema-generator` and
;; call `generator` recursively on the `m/children`. Now, for every child generator, you need to consider the case
;; that the child generator generates no values, and how this might change the final generator.
;;
;; Use `-unreachable-gen?` to test whether your child generator generates no values (we'll call this an "unreachable" schema/generator).
;; If your parent generator cannot generate values, use `-never-gen` to return an unreachable generator.
;;
;; Here are a few examples---compare them with the logic in their respective -schema-generator methods:
;; [:maybe M] would generate like :nil if M were unreachable.
;; [:map [:a M]] would itself be unreachable if M were unreachable.
;; [:map [:a {:optional true} M]] would generate like [:map] if M were unreachable.
;; [:vector M] would generate like [:= []] if M were unreachable.
;; [:vector {:min 1} M] would itself be unreachable if M were unreachable.
(def nil-gen (gen/return nil))
(defn- -child [schema options] (first (m/children schema options)))
(defn- -child-gen [schema options] (generator (-child schema options) options))
(defn -never-gen
"Return a generator of no values that is compatible with -unreachable-gen?."
[{::keys [original-generator-schema] :as _options}]
(with-meta (gen/sized (fn [_]
(m/-fail! ::unsatisfiable-schema
(cond-> {}
original-generator-schema (assoc :schema original-generator-schema)))))
{::never-gen true
::original-generator-schema original-generator-schema}))
(defn -unreachable-gen?
"Returns true iff generator g generators no values."
[g] (-> (meta g) ::never-gen boolean))
(defn -not-unreachable [g] (when-not (-unreachable-gen? g) g))
(defn -unreachable [g] (when (-unreachable-gen? g) g))
(defn- -random [seed] (if seed (random/make-random seed) (random/make-random)))
(defn -min-max [schema options]
(let [{:keys [min max] gen-min :gen/min gen-max :gen/max} (m/properties schema options)]
(when (and min gen-min (< gen-min min))
(m/-fail! ::invalid-property {:key :gen/min, :value gen-min, :min min}))
(when (and max gen-max (> gen-max max))
(m/-fail! ::invalid-property {:key :gen/max, :value gen-min, :max min}))
{:min (or gen-min min)
:max (or gen-max max)}))
(defn- inf-nan [schema options]
(let [{:gen/keys [infinite? NaN?]} (m/properties schema)]
{:infinite? infinite? :NaN? NaN?}))
(defn- gen-fmap [f gen] (or (-unreachable gen) (gen/fmap f gen)))
(defn- gen-fcat [gen] (gen-fmap #(apply concat %) gen))
(defn- gen-tuple [gens] (or (some -unreachable gens) (apply gen/tuple gens)))
(defn- gen-maybe [g] (if (-unreachable-gen? g) nil-gen (gen/one-of [nil-gen g])))
(def ^:private double-default {:infinite? false, :NaN? false})
(defn- gen-double [opts] (gen/double* (-> (into double-default opts) (update :min #(some-> % double)) (update :max #(some-> % double)))))
(defn- gen-vector [{:keys [min max]} g]
(cond
(-unreachable-gen? g) (if (zero? (or min 0)) (gen/return []) g)
(and min (= min max)) (gen/vector g min)
(and min max) (gen/vector g min max)
min (vary-meta (gen/sized #(gen/vector g min (+ min %))) assoc ::generator-ast {:op :vector-min :generator g :min min})
max (gen/vector g 0 max)
:else (gen/vector g)))
(defn- gen-vector-distinct-by [schema {:keys [min] :as m} f g]
(if (-unreachable-gen? g)
(if (= 0 (or min 0)) (gen/return []) g)
(gen/vector-distinct-by f g (into (if (and min (= min max))
{:num-elements min}
(set/rename-keys m {:min :min-elements :max :max-elements}))
{:max-tries 100
:ex-fn #(m/-exception ::distinct-generator-failure (assoc % :schema schema))}))))
(defn- -string-gen [schema options]
(gen-fmap str/join (gen-vector (-min-max schema options) gen/char-alphanumeric)))
(defn- -coll-gen
([schema options] (-coll-gen schema identity options))
([schema f options] (gen-fmap f (gen-vector (-min-max schema options) (-child-gen schema options)))))
(defn- gen-vector-distinct [schema m g] (gen-vector-distinct-by schema m identity g))
(defn- -coll-distinct-gen [schema f options]
(gen-fmap f (gen-vector-distinct schema (-min-max schema options) (-child-gen schema options))))
(defn- ->such-that-opts [schema] {:max-tries 100 :ex-fn #(m/-exception ::such-that-failure (assoc % :schema schema))})
(defn- gen-such-that [schema pred gen] (or (-unreachable gen) (gen/such-that pred gen (->such-that-opts schema))))
(defn -and-gen [schema options]
(gen-such-that schema (m/validator schema options) (-child-gen schema options)))
(defn- gen-one-of [options gs]
(if-some [gs (not-empty (into [] (keep -not-unreachable) gs))]
(if (= 1 (count gs)) (nth gs 0) (gen/one-of gs))
(-never-gen options)))
(defn- -seqable-gen [schema options]
(let [{:keys [min]} (-min-max schema options)
el (-child schema options)]
(gen-one-of
options
(-> []
(cond->
(or (nil? min) (zero? min))
(conj nil-gen))
(into (map #(-coll-gen schema % options))
[identity vec eduction #(into-array #?(:clj Object) %)])
(conj (-coll-distinct-gen schema set options))
(cond->
(and (= :tuple (m/type el))
(= 2 (count (m/children el))))
(conj (let [[k v] (m/children el)]
(generator [:map-of (or (m/properties schema) {}) k v] options))))))))
(defn -or-gen [schema options]
(gen-one-of options (map #(generator % options) (m/children schema options))))
(defn- -merge-keyword-dispatch-map-into-entries [schema]
(let [dispatch (-> schema m/properties :dispatch)]
(cond-> schema
(keyword? dispatch)
(mu/transform-entries
#(map (fn [[k :as e]]
(cond-> e
(not= ::m/default k)
(update 2 mu/merge [:map [dispatch [:= nil k]]]))) %)
(m/options schema)))))
(defn -multi-gen [schema options]
(gen-one-of options (map #(generator (last %) options) (m/entries (-merge-keyword-dispatch-map-into-entries schema) options))))
(defn- -build-map [kvs]
(persistent!
(reduce
(fn [acc [k v]]
(cond (and (= k ::m/default) (map? v)) (reduce-kv assoc! acc v)
(nil? k) acc
:else (assoc! acc k v)))
(transient {}) kvs)))
(defn- -entry-gen [[k s] options]
(cond->> (gen-fmap #(do [k %]) (generator s options)) (-> s m/properties :optional) gen-maybe))
(defn -map-gen [schema options]
(->> schema m/entries (map #(-entry-gen % options)) gen-tuple (gen-fmap -build-map)))
(defn -map-of-gen [schema options]
(->> (gen-tuple (map #(generator % options) (m/children schema options)))
(gen-vector-distinct-by schema (-min-max schema options) #(nth % 0))
(gen-fmap #(into {} %))))
#?(:clj
(defn -re-gen [schema options]
;; [com.gfredericks/test.chuck "0.2.10"+]
(if-let [string-from-regex @(dynaload/dynaload 'com.gfredericks.test.chuck.generators/string-from-regex {:default nil})]
(let [re (or (first (m/children schema options)) (m/form schema options))]
(string-from-regex (re-pattern (str/replace (str re) #"^\^?(.*?)(\$?)$" "$1"))))
(m/-fail! :test-chuck-not-available))))
;; # Approach for recursive generators
;;
;; `-ref-gen` is the only place where recursive generators can be created, and we use `gen/recursive-gen`
;; to handle the recursion. The challenge is that gen/recursive-gen requires _two_ arguments: the base
;; case (scalar gen) and the recursive case (container gen). We need to automatically split the schema argument into
;; these two cases.
;;
;; The main insight we use is that a base case for the schema cannot contain recursive references to itself.
;; A particularly useful base case is simply to "delete" all recursive references. To simulate this, we have the concept of
;; an "unreachable" generator, which represents a "deleted" recursive reference.
;;
;; For infinitely expanding schemas, this will return an unreachable generator--when the base case generator is used,
;; the error message in `-never-gen` will advise users that their schema is infinite.
;;
;;
;; Examples of base cases of some recursive schemas:
;;
;; Schema: [:schema {:registry {::cons [:maybe [:vector [:tuple pos-int? [:ref ::cons]]]]}} ::cons]
;; Base case: [:schema {:registry {::cons [:nil ]}} ::cons]
;;
;; Schema: [:schema
;; {:registry {::ping [:tuple [:= "ping"] [:maybe [:ref ::pong]]]
;; ::pong [:tuple [:= "pong"] [:maybe [:ref ::ping]]]}}
;; ::ping]
;; Base case: [:schema
;; {:registry {::ping [:tuple [:= "ping"] [:maybe [:ref ::pong]]]
;; ::pong [:tuple [:= "pong"] :nil ]}}
;; ::ping]
;;
;; Once we have the base case, we first need determine if the schema is recursive---it's recursive
;; if more than one recursive reference was successfully "deleted" while creating the base case (see below for how we determine recursive references).
;; We can then construct the recursive case by providing `gen/recursive-gen` the base case
;; (this is why this particular base case is so useful) and then propagate the (smaller) generator
;; supplied by `gen/recursive-gen` to convert recursive references.
;; ## Identifying schema recursion
;;
;; Refs are uniquely identified by their paired name and scope. If we see a ref with the
;; same name and scope as another ref we've dereferenced previously, we know that this is a recursion
;; point back to the previously seen ref. The rest of this section explains why.
;;
;; Refs resolve via dynamic scope, which means its dereferenced value is the latest binding found
;; while expanding the schema until the point of finding the ref.
;; This makes the (runtime) scope at the ref's location part of a ref's identity---if the scope
;; is different, then it's (possibly) not the same ref because scope determines how schemas
;; transitively expand.
;;
;; To illustrate why a ref's name is an insufficient identifier, here is a schema that is equivalent to `[:= 42]`:
;;
;; [:schema {:registry {::a [:schema {:registry {::a [:= 42]}}
;; ;; (2)
;; [:ref ::a]]}}
;; ;; (1)
;; [:ref ::a]]
;;
;; If we identify refs just by name, we would have incorrectly detected (2) to be an (infinitely expanding) recursive
;; reference.
;;
;; In studying the previous example, we might think that since (1) and (2) deref to different schemas, it might sufficient to identify refs just by their derefs.
;; Unfortunately this just pushes the problem elsewhere.
;;
;; For example, here is another schema equivalent to `[:= 42]`:
;;
;; [:schema {:registry {::a [:ref ::b] ;; (2)
;; ::b [:schema {:registry {::a [:ref ::b] ;; (4)
;; ::b [:= 42]}}
;; ;; (3)
;; [:ref ::a]]}}
;; ;; (1)
;; [:ref ::a]]
;;
;; If we identified ::a by its deref, it would look like (3) deref'ing to (4)
;; is a recursion point after witnessing (1) deref'ing to (2), since (2) == (4). Except this
;; is wrong since it's a different ::b at (2) and (4)! OTOH, if we identified (2) and (4) with their
;; dynamic scopes along with their form, they would be clearly different. Indeed, this
;; is another way to identify refs: pairing their derefs with their deref's scopes.
;; It is slightly more direct to use the ref's direct name and scope, which is why
;; we choose that identifier. The more general insight is that any schema is identified by its form+scope
;; (note: but only after trimming the scope of irrelevant bindings, see next pararaph).
;; That insight may be useful for detecting recursion at places other than refs.
;;
;; Ref identifiers could be made smarter by trimming irrelevant entries in identifying scope.
;; Not all scope differences are relevant, so generators may expand more than strictly necessary
;; in the quest to find the "same" ref schema again. It could skip over refs that generate exactly the
;; same values, but their scopes are uninterestingly different (eg., unused bindings are different).
;;
;; For example, the following schema is recursive "in spirit" between (1) and (2), but since ::b
;; changes, the scope will differ, so the recursion will be detected between (2) and itself instead
;; (where the scope is constant):
;;
;; [:schema {:registry {::a [:schema {:registry {::b :boolean}}
;; ;; (2)
;; [:or [:ref ::a] [:ref ::b]]]}}
;; [:schema {:registry {::b :int}}
;; ;; (1)
;; [:or [:ref ::a] [:ref ::b]]]]
;; copied to malli.core
(defn- -identify-ref-schema [schema]
{:scope (-> schema m/-options m/-registry mr/-schemas)
:name (m/-ref schema)})
(defn -ref-gen [schema options]
(let [ref-id (-identify-ref-schema schema)]
(or (force (get-in options [::rec-gen ref-id]))
(let [scalar-ref-gen (delay (-never-gen options))
dschema (m/deref schema)]
(cond->> (generator dschema (assoc-in options [::rec-gen ref-id] scalar-ref-gen))
(realized? scalar-ref-gen) (gen/recursive-gen
#(generator dschema (assoc-in options [::rec-gen ref-id] %))))))))
(defn -=>-gen [schema options]
(let [output-generator (generator (:output (m/-function-info schema)) options)]
(gen/return (m/-instrument {:schema schema} (fn [& _] (generate output-generator options))))))
(defn -function-gen [schema options]
(gen/return (m/-instrument {:schema schema, :gen #(generate % options)} nil options)))
(defn -regex-generator [schema options]
(cond-> (generator schema options) (not (m/-regex-op? schema)) (-> vector gen-tuple)))
(defn- -re-entry-gen [e options] (-regex-generator (if (vector? e) (get e 2) e) options))
(defn -cat-gen [schema options]
(->> (m/children schema options) (map #(-re-entry-gen % options)) gen-tuple gen-fcat))
(defn -alt-gen [schema options]
(->> (m/children schema options) (map #(-re-entry-gen % options)) (gen-one-of options)))
(defn -?-gen [schema options]
(let [child (-child schema options)]
(if-some [g (-not-unreachable (generator child options))]
(if (m/-regex-op? child)
(gen/one-of [g (gen/return ())])
(gen/vector g 0 1))
(gen/return ()))))
(defn -*-gen [schema options]
(let [child (-child schema options)]
(cond->> (gen-vector
(-min-max schema options)
(generator child options))
(m/-regex-op? child) gen-fcat)))
(defn -+-gen [schema options]
(let [child (-child schema options)]
(cond->> (gen-vector
(-> (-min-max schema options)
;; When generating from :+ the base minimum value must be 1
;; to ensure that :+ is always fulfilled
(update :min (fnil max 1)))
(generator child options))
(m/-regex-op? child) gen-fcat)))
(defn -repeat-gen [schema options]
(or (some-> (-coll-gen schema options) -not-unreachable (cond-> (m/-regex-op? (-child schema options)) gen-fcat))
(gen/return ())))
(defn -qualified-ident-gen [schema mk-value-with-ns value-with-ns-gen-size pred gen]
(if-let [namespace-unparsed (:namespace (m/properties schema))]
(gen-fmap (fn [k] (mk-value-with-ns (name namespace-unparsed) (name k))) value-with-ns-gen-size)
(gen-such-that schema pred gen)))
(defn -qualified-keyword-gen [schema]
(-qualified-ident-gen schema keyword gen/keyword qualified-keyword? gen/keyword-ns))
(defn -qualified-symbol-gen [schema]
(-qualified-ident-gen schema symbol gen/symbol qualified-symbol? gen/symbol-ns))
(defn- gen-elements [es]
(if (= 1 (count es))
(gen/return (first es))
(gen/elements es)))
(defn- double-gen [schema options]
(gen/double* (merge (let [props (m/properties schema options)]
{:infinite? (get props :gen/infinite? false)
:NaN? (get props :gen/NaN? false)})
(-> (-min-max schema options)
(update :min #(some-> % double))
(update :max #(some-> % double))))))
(defmulti -schema-generator (fn [schema options] (m/type schema options)) :default ::default)
(defmethod -schema-generator ::default [schema options] (ga/gen-for-pred (m/validator schema options)))
(defmethod -schema-generator 'empty? [_ _] (ga/gen-for-pred empty?))
(defmethod -schema-generator :> [schema options] (gen-double {:min (inc (-child schema options))}))
(defmethod -schema-generator :>= [schema options] (gen-double {:min (-child schema options)}))
(defmethod -schema-generator :< [schema options] (gen-double {:max (dec (-child schema options))}))
(defmethod -schema-generator :<= [schema options] (gen-double {:max (-child schema options)}))
(defmethod -schema-generator := [schema options] (gen/return (-child schema options)))
(defmethod -schema-generator :not= [schema options] (gen-such-that schema #(not= % (-child schema options)) gen/any-printable))
(defmethod -schema-generator 'pos? [_ options] (gen/one-of [(gen-double {:min 0.00001}) (gen-fmap inc gen/nat)]))
(defmethod -schema-generator 'neg? [_ options] (gen/one-of [(gen-double {:max -0.00001}) (gen-fmap (comp dec -) gen/nat)]))
(defmethod -schema-generator :not [schema options] (gen-such-that schema (m/validator schema options) (ga/gen-for-pred any?)))
(defmethod -schema-generator :and [schema options] (-and-gen schema options))
(defmethod -schema-generator :andn [schema options] (-and-gen (m/into-schema :and (m/properties schema) (map last (m/children schema)) (m/options schema)) options))
(defmethod -schema-generator :or [schema options] (-or-gen schema options))
(defmethod -schema-generator :orn [schema options] (-or-gen (m/into-schema :or (m/properties schema) (map last (m/children schema)) (m/options schema)) options))
(defmethod -schema-generator ::m/val [schema options] (-child-gen schema options))
(defmethod -schema-generator :map [schema options] (-map-gen schema options))
(defmethod -schema-generator :map-of [schema options] (-map-of-gen schema options))
(defmethod -schema-generator :multi [schema options] (-multi-gen schema options))
(defmethod -schema-generator :vector [schema options] (-coll-gen schema options))
(defmethod -schema-generator :sequential [schema options] (-coll-gen schema options))
(defmethod -schema-generator :set [schema options] (-coll-distinct-gen schema set options))
(defmethod -schema-generator :enum [schema options] (gen-elements (m/children schema options)))
(defmethod -schema-generator :seqable [schema options] (-seqable-gen schema options))
(defmethod -schema-generator :every [schema options] (-seqable-gen schema options)) ;;infinite seqs?
(defmethod -schema-generator :maybe [schema options] (gen-maybe (-child-gen schema options)))
(defmethod -schema-generator :tuple [schema options] (gen-tuple (map #(generator % options) (m/children schema options))))
#?(:clj (defmethod -schema-generator :re [schema options] (-re-gen schema options)))
(defmethod -schema-generator :any [_ _] (ga/gen-for-pred any?))
(defmethod -schema-generator :some [_ _] gen/any-printable)
(defmethod -schema-generator :nil [_ _] nil-gen)
(defmethod -schema-generator :string [schema options] (-string-gen schema options))
(defmethod -schema-generator :int [schema options] (gen/large-integer* (-min-max schema options)))
(defmethod -schema-generator :double [schema options] (double-gen schema options))
(defmethod -schema-generator :float [schema options] (double-gen schema options))
(defmethod -schema-generator :boolean [_ _] gen/boolean)
(defmethod -schema-generator :keyword [_ _] gen/keyword)
(defmethod -schema-generator :symbol [_ _] gen/symbol)
(defmethod -schema-generator :qualified-keyword [schema _] (-qualified-keyword-gen schema))
(defmethod -schema-generator :qualified-symbol [schema _] (-qualified-symbol-gen schema))
(defmethod -schema-generator :uuid [_ _] gen/uuid)
(defmethod -schema-generator :=> [schema options] (-=>-gen schema options))
(defmethod -schema-generator :-> [schema options] (-=>-gen schema options))
(defmethod -schema-generator :function [schema options] (-function-gen schema options))
(defmethod -schema-generator 'ifn? [_ _] gen/keyword)
(defmethod -schema-generator :ref [schema options] (-ref-gen schema options))
(defmethod -schema-generator :schema [schema options] (generator (m/deref schema) options))
(defmethod -schema-generator ::m/schema [schema options] (generator (m/deref schema) options))
(defmethod -schema-generator :merge [schema options] (generator (m/deref schema) options))
(defmethod -schema-generator :union [schema options] (generator (m/deref schema) options))
(defmethod -schema-generator :select-keys [schema options] (generator (m/deref schema) options))
(defmethod -schema-generator :cat [schema options] (-cat-gen schema options))
(defmethod -schema-generator :catn [schema options] (-cat-gen schema options))
(defmethod -schema-generator :alt [schema options] (-alt-gen schema options))
(defmethod -schema-generator :altn [schema options] (-alt-gen schema options))
(defmethod -schema-generator :? [schema options] (-?-gen schema options))
(defmethod -schema-generator :* [schema options] (-*-gen schema options))
(defmethod -schema-generator :+ [schema options] (-+-gen schema options))
(defmethod -schema-generator :repeat [schema options] (-repeat-gen schema options))
;;
;; Creating a generator by different means, centralized under [[-create]]
;;
(defn- -create-from-return [props]
(when (contains? props :gen/return)
(gen/return (:gen/return props))))
(defn- -create-from-elements [props]
(some-> (:gen/elements props) gen-elements))
(extend-protocol Generator
#?(:clj Object, :cljs default)
(-generator [schema options]
(-schema-generator schema (assoc options ::original-generator-schema schema))))
(defn- -create-from-gen
[props schema options]
(or (:gen/gen props)
(when-not (:gen/elements props)
(-generator schema options))))
(defn- -create-from-schema [props options]
(some-> (:gen/schema props) (generator options)))
(defn- -create-from-fmap [gen props schema options]
(when-some [fmap (:gen/fmap props)]
(gen/fmap (m/eval fmap (or options (m/options schema)))
gen)))
(defn- -create [schema options]
(let [props (-merge (m/type-properties schema)
(m/properties schema))
gen (or (-create-from-return props)
(-create-from-elements props)
(-create-from-schema props options)
(-create-from-gen props schema options)
(m/-fail! ::no-generator {:options options
:schema schema}))]
(or (-create-from-fmap gen props schema options)
gen)))
;;
;; public api
;;
(defn generator
([?schema]
(generator ?schema nil))
([?schema options]
(if (::rec-gen options)
;; disable cache while calculating recursive schemas. caches don't distinguish options.
(-create (m/schema ?schema options) options)
(m/-cached (m/schema ?schema options) :generator #(-create % options)))))
(defn generate
([?gen-or-schema]
(generate ?gen-or-schema nil))
([?gen-or-schema {:keys [seed size] :or {size 30} :as options}]
(let [gen (if (gen/generator? ?gen-or-schema) ?gen-or-schema (generator ?gen-or-schema options))]
(rose/root (gen/call-gen gen (-random seed) size)))))
(defn sample
([?gen-or-schema]
(sample ?gen-or-schema nil))
([?gen-or-schema {:keys [seed size] :or {size 10} :as options}]
(let [gen (if (gen/generator? ?gen-or-schema) ?gen-or-schema (generator ?gen-or-schema options))]
(->> (gen/make-size-range-seq size)
(map #(rose/root (gen/call-gen gen %1 %2))
(gen/lazy-random-states (-random seed)))
(take size)))))
;;
;; functions
;;
(defn function-checker
([?schema] (function-checker ?schema nil))
([?schema {::keys [=>iterations] :or {=>iterations 100} :as options}]
(let [schema (m/schema ?schema options)
-try (fn [f] (try [(f) true] (catch #?(:clj Exception, :cljs js/Error) e [e false])))
check (fn [schema]
(let [{:keys [input output guard]} (m/-function-info schema)
input-generator (generator input options)
valid-output? (m/validator output options)
valid-guard? (if guard (m/validator guard options) (constantly true))
validate (fn [f args] (as-> (apply f args) $ (and (valid-output? $) (valid-guard? [args $]))))]
(fn [f]
(let [{:keys [result shrunk]} (->> (prop/for-all* [input-generator] #(validate f %))
(check/quick-check =>iterations))
smallest (-> shrunk :smallest first)]
(when-not (true? result)
(let [explain-input (m/explain input smallest)
[result success] (when-not explain-input (-try (fn [] (apply f smallest))))
explain-output (when (and success (not explain-input)) (m/explain output result))
explain-guard (when (and success guard (not explain-output)) (m/explain guard [smallest result]))]
(cond-> (assoc shrunk ::m/result result)
explain-input (assoc ::m/explain-input explain-input)
explain-output (assoc ::m/explain-output explain-output)
explain-guard (assoc ::m/explain-guard explain-guard)
(ex-message result) (-> (update :result ex-message) (dissoc :result-data)))))))))]
(if (m/-function-info schema)
(check schema)
(if (m/-function-schema? schema)
(let [checkers (map #(function-checker % options) (m/-function-schema-arities schema))]
(fn [x] (->> checkers (keep #(% x)) (seq))))
(m/-fail! ::invalid-function-schema {:type (m/-type schema)}))))))
(defn check
([?schema f] (check ?schema f nil))
([?schema f options]
(let [schema (m/schema ?schema options)]
(m/explain (m/-update-options schema #(assoc % ::m/function-checker function-checker)) f))))
malli/src/malli/impl/regex.cljc
Vendored
+662
View File
@@ -0,0 +1,662 @@
(ns malli.impl.regex
"Regular expressions of sequences implementation namespace.
The implementation is very similar to Packrat or GLL parser combinators.
The parsing functions need to be written in CPS to support backtracking
inside :*, :+ and :repeat. They also need to be trampolined because the
(manually) CPS-converted code (for :*, :+ and :repeat) has to use tail
calls instead of loops and Clojure does not have TCO.
Because backtracking is used we need to memoize (parsing function, seq
position, register stack) triples to avoid exponential behaviour. Discarding
the memoization cache after traversing an input seq also requires trampolining.
Because regular expressions don't use (nontail) recursion by definition, finding
a memoization entry just means the parser already went 'here' and ultimately
failed; much simpler than the graph-structured stacks of GLL. And the register
stack is only there for and used by :repeat.
NOTE: For the memoization to work correctly, every node in the schema tree
must get its own validation/explanation/... function instance. So even every
`(malli.impl.regex/cat)` call must return a new fn instance although it does not
close over anything.
https://epsil.github.io/gll/ is a nice explanation of GLL parser combinators
and has links to papers etc. It also inspired Instaparse, which Engelberg
had a presentation about at Clojure/West 2014.
Despite the CPS and memoization, this implementation looks more like normal
Clojure code than the 'Pike VM' in Seqexp. Hopefully JITs also see it that
way and compile decent machine code for it. It is also much easier to extend
for actual parsing (e.g. encode, decode [and parse?]) instead of just
recognition for `validate`.
For a more detailed explanation of this namespace see also
https://www.metosin.fi/blog/malli-regex-schemas/."
(:refer-clojure :exclude [+ * repeat cat])
(:require [malli.impl.util :as miu])
#?(:bb (:import [java.util ArrayDeque])
:clj (:import [java.util ArrayDeque]
[clojure.lang Util Murmur3]
[java.lang.reflect Array])))
;;;; # Driver Protocols
(defprotocol ^:private Driver
(succeed! [self])
(succeeded? [self])
(pop-thunk! [self]))
(defprotocol ^:private IValidationDriver
(noncaching-park-validator! [driver validator regs pos coll k])
(park-validator! [driver validator regs pos coll k]))
(defprotocol ^:private IExplanationDriver
(noncaching-park-explainer! [driver explainer regs pos coll k])
(park-explainer! [driver explainer regs pos coll k])
(value-path [self pos])
(fail! [self pos errors*])
(latest-errors [self]))
(defprotocol ^:private IParseDriver
(noncaching-park-transformer! [driver transformer regs coll* pos coll k])
(park-transformer! [driver transformer regs coll* pos coll k])
(succeed-with! [self v])
(success-result [self]))
;;;; # Primitives
;;;; ## Seq Item
(defn item-validator [valid?]
(fn [_ _ pos coll k]
(when (and (seq coll) (valid? (first coll)))
(k (inc pos) (rest coll)))))
(defn item-explainer [path schema schema-explainer]
(fn [driver _ pos coll k]
(let [in (value-path driver pos)]
(if (seq coll)
(let [errors (schema-explainer (first coll) in [])]
(if (seq errors)
(fail! driver pos errors)
(k (inc pos) (rest coll))))
(fail! driver pos [(miu/-error path in schema nil :malli.core/end-of-input)])))))
(defn item-parser [parse]
(fn [_ _ pos coll k]
(when (seq coll)
(let [v (parse (first coll))]
(when-not (= v :malli.core/invalid)
(k v (inc pos) (rest coll)))))))
(defn item-unparser [unparse] (fn [v] (miu/-map-valid vector (unparse v))))
(defn item-encoder [valid? encode]
(fn [_ _ coll* pos coll k]
(when (seq coll)
(let [v (first coll)]
(when (valid? v)
(k (conj coll* (encode v)) (inc pos) (rest coll)))))))
(defn item-decoder [decode valid?]
(fn [_ _ coll* pos coll k]
(when (seq coll)
(let [v (decode (first coll))]
(when (valid? v)
(k (conj coll* v) (inc pos) (rest coll)))))))
(defn item-transformer [method validator t]
(case method
:encode (item-encoder validator t)
:decode (item-decoder t validator)))
;;;; ## End of Seq
(defn end-validator [] (fn [_ _ pos coll k] (when (empty? coll) (k pos coll))))
(defn end-explainer [schema path]
(fn [driver _ pos coll k]
(if (empty? coll)
(k pos coll)
(fail! driver pos (list (miu/-error path (value-path driver pos) schema (first coll) :malli.core/input-remaining))))))
(defn end-parser [] (fn [_ _ pos coll k] (when (empty? coll) (k nil pos coll))))
(defn end-transformer [] (fn [_ _ coll* pos coll k] (when (empty? coll) (k coll* pos coll))))
;;;; ## Unit
(defn pure-parser [v] (fn [_ _ pos coll k] (k v pos coll)))
(defn pure-unparser [_] [])
;;;; # Combinators
;;;; ## Functor
(defn fmap-parser [f p]
(fn [driver regs pos coll k]
(p driver regs pos coll (fn [v pos coll] (k (f v) pos coll)))))
;;;; ## Catenation
(defn- entry->regex [?kr] (if (vector? ?kr) (get ?kr 1) ?kr))
(defn cat-validator
([] (fn [_ _ pos coll k] (k pos coll)))
([?kr & ?krs]
(reduce (fn [acc ?kr]
(let [r* (entry->regex ?kr)]
(fn [driver regs pos coll k]
(acc driver regs pos coll (fn [pos coll] (r* driver regs pos coll k))))))
(entry->regex ?kr) ?krs)))
(defn cat-explainer
([] (fn [_ _ pos coll k] (k pos coll)))
([?kr & ?krs]
(reduce (fn [acc ?kr]
(let [r* (entry->regex ?kr)]
(fn [driver regs pos coll k]
(acc driver regs pos coll (fn [pos coll] (r* driver regs pos coll k))))))
(entry->regex ?kr) ?krs)))
(defn cat-parser
([] (fn [_ _ pos coll k] (k [] pos coll)))
([r & rs]
(let [sp (reduce (fn [acc r]
(fn [driver regs coll* pos coll k]
(r driver regs pos coll
(fn [v pos coll] (acc driver regs (conj coll* v) pos coll k)))))
(fn [_ _ coll* pos coll k] (k coll* pos coll))
(reverse (cons r rs)))]
(fn [driver regs pos coll k] (sp driver regs [] pos coll k)))))
;; we need to pass in the malli.core/tags function as an arg to avoid a cyclic reference
(defn catn-parser
([tags] (fn [_ _ pos coll k] (k (tags {}) pos coll)))
([tags kr & krs]
(let [sp (reduce (fn [acc [tag r]]
(fn [driver regs m pos coll k]
(r driver regs pos coll
(fn [v pos coll] (acc driver regs (assoc m tag v) pos coll k)))))
(fn [_ _ m pos coll k] (k (tags m) pos coll))
(reverse (cons kr krs)))]
(fn [driver regs pos coll k] (sp driver regs {} pos coll k)))))
(defn cat-unparser [& unparsers]
(let [unparsers (vec unparsers)]
(fn [tup]
(if (and (vector? tup) (= (count tup) (count unparsers)))
(miu/-reduce-kv-valid (fn [coll i unparser] (miu/-map-valid #(into coll %) (unparser (get tup i))))
[] unparsers)
:malli.core/invalid))))
;; cyclic ref avoidance here as well for malli.core/tags?
(defn catn-unparser [tags? & unparsers]
(let [unparsers (apply array-map (mapcat identity unparsers))]
(fn [m]
(if (and (tags? m) (= (count (:values m)) (count unparsers)))
(miu/-reduce-kv-valid (fn [coll tag unparser]
(if-some [kv (find (:values m) tag)]
(miu/-map-valid #(into coll %) (unparser (val kv)))
:malli.core/invalid))
;; `m` is in hash order, so have to iterate over `unparsers` to restore seq order:
[] unparsers)
:malli.core/invalid))))
(defn cat-transformer
([] (fn [_ _ coll* pos coll k] (k coll* pos coll)))
([?kr & ?krs]
(reduce (fn [acc ?kr]
(let [r (entry->regex ?kr)]
(fn [driver regs coll* pos coll k]
(acc driver regs coll* pos coll (fn [coll* pos coll] (r driver regs coll* pos coll k))))))
(entry->regex ?kr) ?krs)))
;;;; ## Alternation
(defn alt-validator [?kr & ?krs]
(reduce (fn [r ?kr]
(let [r* (entry->regex ?kr)]
(fn [driver regs pos coll k]
(park-validator! driver r* regs pos coll k) ; remember fallback
(park-validator! driver r regs pos coll k))))
(entry->regex ?kr) ?krs))
(defn alt-explainer [?kr & ?krs]
(reduce (fn [r ?kr]
(let [r* (entry->regex ?kr)]
(fn [driver regs pos coll k]
(park-explainer! driver r* regs pos coll k) ; remember fallback
(park-explainer! driver r regs pos coll k))))
(entry->regex ?kr) ?krs))
(defn alt-parser [& rs]
(reduce (fn [r r*]
(fn [driver regs pos coll k]
(park-validator! driver r* regs pos coll k) ; remember fallback
(park-validator! driver r regs pos coll k)))
rs))
;; cyclic ref avoidance for malli.core/tag
(defn altn-parser [tag kr & krs]
(reduce (fn [r [t r*]]
(let [r* (fmap-parser (fn [v] (tag t v)) r*)]
(fn [driver regs pos coll k]
(park-validator! driver r* regs pos coll k) ; remember fallback
(park-validator! driver r regs pos coll k))))
(let [[t r] kr]
(fmap-parser (fn [v] (tag t v)) r))
krs))
(defn alt-unparser [& unparsers]
(fn [x]
(reduce (fn [_ unparse] (miu/-map-valid reduced (unparse x)))
:malli.core/invalid unparsers)))
;; cyclic ref avoidance for malli.core/tag?
(defn altn-unparser [tag? & unparsers]
(let [unparsers (into {} unparsers)]
(fn [x]
(if (tag? x)
(if-some [kv (find unparsers (:key x))]
((val kv) (:value x))
:malli.core/invalid)
:malli.core/invalid))))
(defn alt-transformer [?kr & ?krs]
(reduce (fn [r ?kr]
(let [r* (entry->regex ?kr)]
(fn [driver regs coll* pos coll k]
(park-transformer! driver r* regs coll* pos coll k) ; remember fallback
(park-transformer! driver r regs coll* pos coll k))))
(entry->regex ?kr) ?krs))
;;;; ## Option
(defn ?-validator [p] (alt-validator p (cat-validator)))
(defn ?-explainer [p] (alt-explainer p (cat-explainer)))
(defn ?-parser [p] (alt-parser p (pure-parser nil)))
(defn ?-unparser [p] (alt-unparser p pure-unparser))
(defn ?-transformer [p] (alt-transformer p (cat-transformer)))
;;;; ## Kleene Star
(defn *-validator [p]
(let [*p-epsilon (cat-validator)]
(fn *p [driver regs pos coll k]
(park-validator! driver *p-epsilon regs pos coll k) ; remember fallback
(p driver regs pos coll (fn [pos coll] (park-validator! driver *p regs pos coll k)))))) ; TCO
(defn *-explainer [p]
(let [*p-epsilon (cat-explainer)]
(fn *p [driver regs pos coll k]
(park-explainer! driver *p-epsilon regs pos coll k) ; remember fallback
(p driver regs pos coll (fn [pos coll] (park-explainer! driver *p regs pos coll k)))))) ; TCO
(defn *-parser [p]
(let [*p-epsilon (fn [_ _ coll* pos coll k] (k coll* pos coll))] ; TCO
(fn *p
([driver regs pos coll k] (*p driver regs [] pos coll k))
([driver regs coll* pos coll k]
(park-transformer! driver *p-epsilon regs coll* pos coll k) ; remember fallback
(p driver regs pos coll
(fn [v pos coll] (park-transformer! driver *p regs (conj coll* v) pos coll k))))))) ; TCO
(defn *-unparser [up]
(fn [v]
(reduce (fn [acc v]
(let [result (up v)]
(if (miu/-invalid? result)
(reduced result)
(into acc result))))
[] v)))
(defn *-transformer [p]
(let [*p-epsilon (cat-transformer)]
(fn *p [driver regs coll* pos coll k]
(park-transformer! driver *p-epsilon regs coll* pos coll k) ; remember fallback
(p driver regs coll* pos coll
(fn [coll* pos coll] (park-transformer! driver *p regs coll* pos coll k)))))) ; TCO
;;;; ## Non-Kleene Plus
(defn +-validator [p] (cat-validator p (*-validator p)))
(defn +-explainer [p] (cat-explainer p (*-explainer p)))
(defn +-parser [p] (fmap-parser (fn [[v vs]] (into [v] vs)) (cat-parser p (*-parser p))))
(defn +-unparser [up]
(let [up* (*-unparser up)]
(fn [x]
(if (and (vector? x) (<= 1 (count x)))
(up* x)
:malli.core/invalid))))
(defn +-transformer [p] (cat-transformer p (*-transformer p)))
;;;; ## Repeat
;; eagerly repeat a child until either:
;; - the child consumes no elements
;; - then bail to check for remaining elements
;; - we run out of repetitions via :max
;; - then bail to check for remaining elements
;; - we have repeated at least :min times and the coll is empty
;; - success case
(defn repeat-validator [min max p]
(let [rep-epsilon (cat-validator)]
(letfn [(compulsories [driver regs pos coll k]
(if (< (peek regs) min)
(p driver regs pos coll
(fn [pos coll]
(noncaching-park-validator! driver
(fn [driver stack pos coll k]
(compulsories driver (conj (pop stack) (inc (peek stack))) pos coll k))
regs pos coll k))) ; TCO
(optionals driver regs pos coll k)))
(optionals [driver regs pos coll k]
(if (and (< (peek regs) max)
(<= (peek regs) pos)
(seq coll))
(do
(park-validator! driver rep-epsilon regs pos coll k) ; remember fallback
(p driver regs pos coll
(fn [pos coll]
(park-validator! driver
(fn [driver regs pos coll k]
(optionals driver (conj (pop regs) (inc (peek regs))) pos coll k))
regs pos coll k)))) ; TCO
(k pos coll)))]
(fn [driver regs pos coll k] (compulsories driver (conj regs 0) pos coll k)))))
(defn repeat-explainer [min max p]
(let [rep-epsilon (cat-explainer)]
(letfn [(compulsories [driver regs pos coll k]
(if (< (peek regs) min)
(p driver regs pos coll
(fn [pos coll]
(noncaching-park-explainer! driver
(fn [driver regs pos coll k]
(compulsories driver (conj (pop regs) (inc (peek regs))) pos coll k))
regs pos coll k))) ; TCO
(optionals driver regs pos coll k)))
(optionals [driver regs pos coll k]
(if (and (< (peek regs) max)
(<= (peek regs) pos)
(seq coll))
(do
(park-explainer! driver rep-epsilon regs pos coll k) ; remember fallback
(p driver regs pos coll
(fn [pos coll]
(park-explainer! driver
(fn [driver regs pos coll k]
(optionals driver (conj (pop regs) (inc (peek regs))) pos coll k))
regs pos coll k)))) ; TCO
(k pos coll)))]
(fn [driver regs pos coll k] (compulsories driver (conj regs 0) pos coll k)))))
(defn repeat-parser [min max p]
(let [rep-epsilon (fn [_ _ coll* pos coll k] (k coll* pos coll))]
(letfn [(compulsories [driver regs coll* pos coll k]
(if (< (peek regs) min)
(p driver regs pos coll
(fn [v pos coll]
(noncaching-park-transformer! driver
(fn [driver regs coll* pos coll k]
(compulsories driver (conj (pop regs) (inc (peek regs))) (conj coll* v) pos coll k))
regs coll* pos coll k))) ; TCO
(optionals driver regs coll* pos coll k)))
(optionals [driver regs coll* pos coll k]
(if (and (< (peek regs) max)
(<= (peek regs) pos)
(seq coll))
(do
(park-transformer! driver rep-epsilon regs coll* pos coll k) ; remember fallback
(p driver regs pos coll
(fn [v pos coll]
(park-transformer!
driver
(fn [driver regs coll* pos coll k]
(optionals driver (conj (pop regs) (inc (peek regs))) (conj coll* v) pos coll k))
regs coll* pos coll k)))) ; TCO
(k coll* pos coll)))]
(fn [driver regs pos coll k] (compulsories driver (conj regs 0) [] pos coll k)))))
(defn repeat-unparser [min max up]
(let [up* (*-unparser up)]
(fn [v]
(if (and (vector? v) (<= min (count v) max))
(up* v)
:malli.core/invalid))))
(defn repeat-transformer [min max p]
(let [rep-epsilon (cat-transformer)]
(letfn [(compulsories [driver regs coll* pos coll k]
(if (< (peek regs) min)
(p driver regs coll* pos coll
(fn [coll* pos coll]
(noncaching-park-transformer! driver
(fn [driver regs coll* pos coll k]
(compulsories driver (conj (pop regs) (inc (peek regs))) coll* pos coll k))
regs coll* pos coll k))) ; TCO
(optionals driver regs coll* pos coll k)))
(optionals [driver regs coll* pos coll k]
(if (and (< (peek regs) max)
(<= (peek regs) pos)
(seq coll))
(do
(park-transformer! driver rep-epsilon regs coll* pos coll k) ; remember fallback
(p driver regs coll* pos coll
(fn [coll* pos coll]
(park-transformer! driver
(fn [driver regs coll* pos coll k]
(optionals driver (conj (pop regs) (inc (peek regs))) coll* pos coll k))
regs coll* pos coll k)))) ; TCO
(k coll* pos coll)))]
(fn [driver regs coll* pos coll k] (compulsories driver (conj regs 0) coll* pos coll k)))))
;;;; # Shared Drivers
(defn- make-stack [] #?(:clj (ArrayDeque.), :cljs #js []))
(defn- empty-stack? [^ArrayDeque stack] #?(:clj (.isEmpty stack), :cljs (zero? (alength stack))))
(defprotocol ^:private ICache
(ensure-cached! [cache f pos regs]))
(deftype ^:private CacheEntry [^long hash f ^long pos regs])
#?(:clj (set! *unchecked-math* true))
;; Custom hash set so that Cljs Malli users can have decent perf without having to to set up Closure ES6 Set polyfill.
;; Uses quadratic probing with power-of-two sizes and triangular numbers, what a nice trick!
(deftype Cache
#?(:clj [^:unsynchronized-mutable ^"[Ljava.lang.Object;" values, ^:unsynchronized-mutable ^long size]
:cljs [^:mutable values, ^:mutable size])
ICache
(ensure-cached! [_ f pos regs]
(when (> (unchecked-inc size) (bit-shift-right (alength values) 1)) ; potential new load factor > 0.5
;; Rehash:
(let [capacity* (bit-shift-left (alength values) 1)
^objects values* #?(:bb (object-array capacity*)
:clj (Array/newInstance Object capacity*)
:cljs (object-array capacity*))
max-index (unchecked-dec capacity*)]
(let [len (alength values)]
(loop [i 0]
(when (< i len)
(when-some [^CacheEntry v (aget values i)]
(loop [i* (bit-and (.-hash v) max-index)
collisions 0]
(if (aget values* i*)
(let [collisions (unchecked-inc collisions)]
(recur
(bit-and (unchecked-add i* collisions) max-index)
collisions))
(aset values* i* v))))
(recur (unchecked-inc i)))))
(set! values values*)))
(let [capacity (alength values)
max-index (unchecked-dec capacity)
#?@(:clj [pos (.longValue ^Long pos)])
;; Unfortunately `hash-combine` hashes its second argument on clj and neither argument on cljs:
h #?(:bb (-> (hash f) (hash-combine pos) (hash-combine regs))
:clj (-> (.hashCode ^Object f) (Util/hashCombine (Murmur3/hashLong pos)) (Util/hashCombine (Util/hash regs)))
:cljs (-> (hash f) (hash-combine (hash pos)) (hash-combine (hash regs))))]
(loop [i (bit-and h max-index), collisions 0]
(if-some [^CacheEntry entry (aget values i)]
(or (and (= (.-hash entry) h)
(= (.-f entry) f)
(= (.-pos entry) pos)
(= (.-regs entry) regs))
(let [collisions (unchecked-inc collisions)]
(recur (bit-and (unchecked-add i collisions) max-index) ; i = (i + collisions) % capacity
collisions)))
(do
(aset values i (CacheEntry. h f pos regs))
(set! size (unchecked-inc size))
false))))))
(defn- make-cache [] (Cache. (object-array 2) 0))
#?(:clj (set! *unchecked-math* false))
(deftype ^:private CheckDriver
#?(:clj [^:unsynchronized-mutable ^boolean success, ^ArrayDeque stack, cache]
:cljs [^:mutable success, stack, cache])
Driver
(succeed! [_] (set! success (boolean true)))
(succeeded? [_] success)
(pop-thunk! [_] (when-not (empty-stack? stack) (.pop stack)))
IValidationDriver
(noncaching-park-validator! [self validator regs pos coll k] (.push stack #(validator self regs pos coll k)))
(park-validator! [self validator regs pos coll k]
(when-not (ensure-cached! cache validator pos regs)
(noncaching-park-validator! self validator regs pos coll k))))
(deftype ^:private ParseDriver
#?(:clj [^:unsynchronized-mutable ^boolean success, ^ArrayDeque stack, cache
^:unsynchronized-mutable result]
:cljs [^:mutable success, stack, cache, ^:mutable result])
Driver
(succeed! [_] (set! success (boolean true)))
(succeeded? [_] success)
(pop-thunk! [_] (when-not (empty-stack? stack) (.pop stack)))
IValidationDriver
(noncaching-park-validator! [self validator regs pos coll k] (.push stack #(validator self regs pos coll k)))
(park-validator! [self validator regs pos coll k]
(when-not (ensure-cached! cache validator pos regs)
(noncaching-park-validator! self validator regs pos coll k)))
IParseDriver
(noncaching-park-transformer! [driver transformer regs coll* pos coll k]
(.push stack #(transformer driver regs coll* pos coll k)))
(park-transformer! [driver transformer regs coll* pos coll k]
(when-not (ensure-cached! cache transformer pos regs)
(noncaching-park-transformer! driver transformer regs coll* pos coll k)))
(succeed-with! [self v] (succeed! self) (set! result v))
(success-result [_] result))
;;;; # Validator
(defn validator [p]
(let [p (cat-validator p (end-validator))]
(fn [coll]
(and (sequential? coll)
(let [driver (CheckDriver. false (make-stack) (make-cache))]
(p driver () 0 coll (fn [_ _] (succeed! driver)))
(or (succeeded? driver)
(loop []
(if-some [thunk (pop-thunk! driver)]
(do
(thunk)
(or (succeeded? driver) (recur)))
false))))))))
;;;; # Explainer
(deftype ^:private ExplanationDriver
#?(:clj [^:unsynchronized-mutable ^boolean success, ^ArrayDeque stack, cache
in, ^:unsynchronized-mutable errors-max-pos, ^:unsynchronized-mutable errors]
:cljs [^:mutable success, stack, cache, in, ^:mutable errors-max-pos, ^:mutable errors])
Driver
(succeed! [_] (set! success (boolean true)))
(succeeded? [_] success)
(pop-thunk! [_] (when-not (empty-stack? stack) (.pop stack)))
IExplanationDriver
(noncaching-park-explainer! [self validator regs pos coll k] (.push stack #(validator self regs pos coll k)))
(park-explainer! [self validator regs pos coll k]
(when-not (ensure-cached! cache validator pos regs)
(noncaching-park-explainer! self validator regs pos coll k)))
(value-path [_ pos] (conj in pos))
(fail! [_ pos errors*]
(cond
(> pos errors-max-pos) (do
(set! errors-max-pos pos)
(set! errors errors*))
(= pos errors-max-pos) (set! errors (into errors errors*))))
(latest-errors [_] errors))
(defn explainer [schema path p]
(let [p (cat-explainer p (end-explainer schema path))]
(fn [coll in errors]
(if (sequential? coll)
(let [pos 0
driver (ExplanationDriver. false (make-stack) (make-cache) in pos [])]
(p driver () pos coll (fn [_ _] (succeed! driver)))
(if (succeeded? driver)
errors
(loop []
(if-some [thunk (pop-thunk! driver)]
(do
(thunk)
(if (succeeded? driver) errors (recur)))
(into errors (latest-errors driver))))))
(conj errors (miu/-error path in schema coll :malli.core/invalid-type))))))
;;;; # Parser
(defn parser [p]
(let [p (cat-parser p (end-parser))]
(fn [coll]
(if (sequential? coll)
(let [driver (ParseDriver. false (make-stack) (make-cache) nil)]
(p driver () 0 coll (fn [v _ _] (succeed-with! driver v)))
(if (succeeded? driver)
(first (success-result driver))
(loop []
(if-some [thunk (pop-thunk! driver)]
(do
(thunk)
(if (succeeded? driver) (first (success-result driver)) (recur)))
:malli.core/invalid))))
:malli.core/invalid))))
;;;; # Transformer
(defn transformer [p]
(let [p (cat-transformer p (end-transformer))]
(fn [coll]
(if (sequential? coll)
(let [driver (ParseDriver. false (make-stack) (make-cache) nil)]
(p driver () [] 0 coll (fn [coll* _ _] (succeed-with! driver coll*)))
(if (succeeded? driver)
(success-result driver)
(loop []
(if-some [thunk (pop-thunk! driver)]
(do
(thunk)
(if (succeeded? driver) (success-result driver) (recur)))
coll))))
coll))))
malli/src/malli/impl/util.cljc
Vendored
+79
View File
@@ -0,0 +1,79 @@
(ns malli.impl.util
#?(:clj (:import #?(:bb (clojure.lang MapEntry)
:clj (clojure.lang MapEntry LazilyPersistentVector))
(java.util.concurrent TimeoutException TimeUnit FutureTask))))
(def ^:const +max-size+ #?(:clj Long/MAX_VALUE, :cljs (.-MAX_VALUE js/Number)))
(defn -entry [k v] #?(:clj (MapEntry. k v), :cljs (MapEntry. k v nil)))
(defn -invalid? [x] #?(:clj (identical? x :malli.core/invalid), :cljs (keyword-identical? x :malli.core/invalid)))
(defn -map-valid [f v] (if (-invalid? v) v (f v)))
(defn -map-invalid [f v] (if (-invalid? v) (f v) v))
(defn -reduce-kv-valid [f init coll] (reduce-kv (comp #(-map-invalid reduced %) f) init coll))
(defn -last [x] (if (vector? x) (peek x) (last x)))
(defn -some [pred coll] (reduce (fn [ret x] (if (pred x) (reduced true) ret)) nil coll))
(defn -merge [m1 m2] (if m1 (persistent! (reduce-kv assoc! (transient m1) m2)) m2))
(defn -error
([path in schema value] {:path path, :in in, :schema schema, :value value})
([path in schema value type] {:path path, :in in, :schema schema, :value value, :type type}))
(defn -vmap
([os] (-vmap identity os))
([f os] #?(:clj (let [c (count os)]
(if-not (zero? c)
(let [oa (object-array c), iter (.iterator ^Iterable os)]
(loop [n 0] (when (.hasNext iter) (aset oa n (f (.next iter))) (recur (unchecked-inc n))))
#?(:bb (vec oa)
:clj (LazilyPersistentVector/createOwning oa))) []))
:cljs (into [] (map f) os))))
#?(:clj
(defn ^:no-doc -run [^Runnable f ms]
(let [task (FutureTask. f), t (Thread. task)]
(try
(.start t) (.get task ms TimeUnit/MILLISECONDS)
(catch TimeoutException _ (.cancel task true) ::timeout)
(catch Exception e (.cancel task true) (throw e))))))
#?(:clj
(defmacro -combine-n
[c n xs]
(let [syms (repeatedly n gensym)
g (gensym "preds__")
bs (interleave syms (map (fn [n] `(nth ~g ~n)) (range n)))
arg (gensym "arg__")
body `(~c ~@(map (fn [sym] `(~sym ~arg)) syms))]
`(let [~g (-vmap ~xs) ~@bs]
(fn [~arg] ~body)))))
#?(:clj
(defmacro -pred-composer
[c n]
(let [preds (gensym "preds__")
f (gensym "f__")
cases (mapcat (fn [i] [i `(-combine-n ~c ~i ~preds)]) (range 2 (inc n)))
else `(let [p# (~f (take ~n ~preds)) q# (~f (drop ~n ~preds))]
(fn [x#] (~c (p# x#) (q# x#))))]
`(fn ~f [~preds]
(case (count ~preds)
0 (constantly (boolean (~c)))
1 (first ~preds)
~@cases
~else)))))
(def ^{:arglists '([[& preds]])} -every-pred
#?(:clj (-pred-composer and 16)
:cljs (fn [preds] (fn [m] (boolean (reduce #(or (%2 m) (reduced false)) true preds))))))
(def ^{:arglists '([[& preds]])} -some-pred
#?(:clj (-pred-composer or 16)
:cljs (fn [preds] (fn [x] (boolean (some #(% x) preds))))))
#?(:clj
(defmacro predicate-schemas* [var-syms]
`(-> {}
~@(for [vsym var-syms]
`(malli.core/-register-var '~vsym ~vsym)))))
malli/src/malli/instrument.clj
Vendored
+162
View File
@@ -0,0 +1,162 @@
(ns malli.instrument
(:require [clojure.walk :as walk]
[malli.core :as m]
[malli.generator :as mg]))
(defn -find-var [n s] (find-var (symbol (str n "/" s))))
(defn -sequential [x] (cond (set? x) x (sequential? x) x :else [x]))
(defn -f->original [f] (-> f meta ::original (or f)))
(defn -original [v] (let [f (deref v)] (-f->original f)))
(defn -filter-ns [& ns] (let [ns (set ns)] (fn [n _ _] (contains? ns n))))
(defn -filter-var [f] (fn [n s _] (f (-find-var n s))))
(defn -filter-schema [f] (fn [_ _ {:keys [schema]}] (f schema)))
(defn- -primitive-fn? [f]
(and (fn? f) (boolean (some (fn [^Class c] (.startsWith (.getName c) "clojure.lang.IFn$")) (supers (class f))))))
(defn -strument!
([] (-strument! nil))
([{:keys [mode data filters gen report] :or {mode :instrument, data (m/function-schemas)} :as options}]
(doall
(for [[n d] data, [s d] d]
(when-let [v (-find-var n s)]
(when (and (bound? v)
(or (not (-primitive-fn? @v))
(println (str "WARNING: Not instrumenting primitive fn " v))))
(when (or (not filters) (some #(% n s d) filters))
(case mode
:instrument (let [dgen (as-> (merge (select-keys options [:scope :report :gen]) d) $
(cond-> $ report (update :report (fn [r] (fn [t data] (r t (assoc data :fn-name (symbol (name n) (name s))))))))
(cond (and gen (true? (:gen d))) (assoc $ :gen gen)
(true? (:gen d)) (dissoc $ :gen)
:else $))]
(alter-var-root v (fn [f]
(when (-primitive-fn? f)
(m/-fail! ::cannot-instrument-primitive-fn {:v v}))
(let [f (-f->original f)]
(-> (m/-instrument dgen f) (with-meta {::original f}))))))
:unstrument (alter-var-root v -f->original)
(mode v d))
v)))))))
(defn -schema [v]
(let [{:keys [malli/schema arglists]} (meta v)]
(or schema (as-> (seq (keep (comp :malli/schema meta) arglists)) $
(when (= (count arglists) (count $)) (cond->> $ (next $) (into [:function])))))))
(defn -collect! [v]
(let [{:keys [ns name] :as m} (meta v)]
(when-let [s (-schema v)] (m/-register-function-schema! (-> ns str symbol) name s (m/-unlift-keys m "malli")))))
(defn clj-collect!
([] (clj-collect! {:ns *ns*}))
([{:keys [ns]}]
(not-empty (reduce (fn [acc v] (let [v (-collect! v)] (cond-> acc v (conj v)))) #{} (vals (mapcat ns-publics (-sequential ns)))))))
;;
;; CLJS macro for collecting function schemas
;;
(let [cljs-find-ns (fn [env] (when (:ns env) (ns-resolve 'cljs.analyzer.api 'find-ns)))
cljs-ns-interns (fn [env] (when (:ns env) (ns-resolve 'cljs.analyzer.api 'ns-interns)))]
(defn -cljs-collect!* [env simple-name {:keys [meta] :as var-map}]
;; when collecting google closure or other js code symbols will not have namespaces
(when (namespace (:name var-map))
(let [ns (symbol (namespace (:name var-map)))
find-ns' (cljs-find-ns env)
ns-interns' (cljs-ns-interns env)
schema (:malli/schema meta)]
(when schema
(let [-qualify-sym (fn [form]
(if (symbol? form)
(if (simple-symbol? form)
(let [ns-data (find-ns' ns)
intern-keys (set (keys (ns-interns' ns)))]
(cond
;; a referred symbol
(get-in ns-data [:uses form])
(let [form-ns (str (get-in ns-data [:uses form]))]
(symbol form-ns (str form)))
;; interned var
(contains? intern-keys form)
(symbol (str ns) (str form))
:else
;; a cljs.core var, do not qualify it
form))
(let [ns-part (symbol (namespace form))
name-part (name form)
full-ns (get-in (find-ns' ns) [:requires ns-part])]
(symbol (str full-ns) name-part)))
form))
schema* (walk/postwalk -qualify-sym schema)
metadata (assoc
(walk/postwalk -qualify-sym (m/-unlift-keys meta "malli"))
:metadata-schema? true)]
`(do
(m/-register-function-schema! '~ns '~simple-name ~schema* ~metadata :cljs identity)
'~(:name var-map))))))))
(defmacro cljs-collect!
([] `(cljs-collect! ~{:ns (symbol (str *ns*))}))
([opts]
(let [ns-publics' (when (:ns &env) (ns-resolve 'cljs.analyzer.api 'ns-publics))]
(reduce (fn [acc [var-name var-map]] (let [v (-cljs-collect!* &env var-name var-map)] (cond-> acc v (conj v))))
#{}
(mapcat (fn [n]
(let [ns-sym (cond (symbol? n) n
;; handles (quote ns-name) - quoted symbols passed to cljs macros show up this way.
(list? n) (second n)
:else (symbol (str n)))]
(ns-publics' ns-sym)))
;; support quoted vectors of ns symbols in cljs
(let [nses (:ns opts)
nses (if (and (= 'quote (first nses)) (coll? (second nses)))
(second nses)
nses)]
(-sequential nses)))))))
;;
;; public api
;;
(defn check
"Checks all registered function schemas using generative testing.
Returns nil or a map of symbol -> explanation in case of errors."
([] (check nil))
([options]
(let [res* (atom {})]
(-strument! (assoc options :mode (fn [v {:keys [schema]}]
(some->> (mg/check schema (-original v))
(swap! res* assoc (symbol v))))))
(not-empty @res*))))
(defmacro collect!
"Reads all public Vars from a given namespace(s) and registers a function (var) schema if `:malli/schema`
metadata is present. The following metadata key can be used:
| key | description |
| ----------------|-------------|
| `:malli/schema` | function schema
| `:malli/scope` | optional set of scope definitions, defaults to `#{:input :output}`
| `:malli/report` | optional side-effecting function of `key data -> any` to report problems, defaults to `m/-fail!`
| `:malli/gen` | optional value `true` or function of `schema -> schema -> value` to be invoked on the args to get the return value"
([] `(collect! {:ns (symbol (str ~'*ns*))}))
([opts]
(if (:ns &env)
`(cljs-collect! ~opts)
`(clj-collect! ~opts))))
(defn instrument!
"Applies instrumentation for a filtered set of function Vars (e.g. `defn`s).
See [[malli.core/-instrument]] for possible options."
([] (instrument! nil))
([options] (-strument! (assoc options :mode :instrument))))
(defn unstrument!
"Removes instrumentation from a filtered set of function Vars (e.g. `defn`s).
See [[malli.core/-instrument]] for possible options."
([] (unstrument! nil))
([options] (-strument! (assoc options :mode :unstrument))))
malli/src/malli/instrument.cljs
Vendored
+158
View File
@@ -0,0 +1,158 @@
(ns malli.instrument
(:require-macros [malli.instrument])
(:require [clojure.string :as str]
[goog.object :as g]
[malli.core :as m]
[malli.generator :as mg]))
(defn ^:private -ns-js-path [ns] (into-array (map munge (str/split (str ns) #"\."))))
(defn ^:private -prop-js-path [ns prop] (into-array (map munge (conj (str/split (str ns) #"\.") (name prop)))))
(defn ^:private -get-prop [ns prop] (g/getValueByKeys goog/global (-prop-js-path ns prop)))
(defn ^:private -get-ns [ns] (g/getValueByKeys goog/global (-ns-js-path ns)))
(defn ^:private -find-var [n s] (-get-prop n s))
(defn ^:private -original [f] (g/get f "malli$instrument$original"))
(defn ^:private -instrumented? [f] (true? (g/get f "malli$instrument$instrumented?")))
(defn ^:private meta-fn
;; Taken from https://clojure.atlassian.net/browse/CLJS-3018
;; Because the current MetaFn implementation can cause quirky errors in CLJS
[f m]
(let [new-f (goog/bind f #js{})]
(js/Object.assign new-f f)
(specify! new-f IMeta #_:clj-kondo/ignore (-meta [_] m))
new-f))
(defn -filter-ns [& ns] (fn [n _ _] ((set ns) n)))
(defn -filter-var [f] (fn [n s d] (f (Var. (constantly (-find-var n s)) (symbol n s) d))))
(defn -filter-schema [f] (fn [_ _ {:keys [schema]}] (f schema)))
(defn -arity->schema
[fn-schema]
(into {} (map (fn [schema] [(:arity (m/-function-info (m/schema schema))) schema])
(rest fn-schema))))
(defn -variadic? [f] (g/get f "cljs$core$IFn$_invoke$arity$variadic"))
(defn -max-fixed-arity [f] (g/get f "cljs$lang$maxFixedArity"))
(defn -pure-variadic? [f]
(let [max-fixed-arity (-max-fixed-arity f)]
(and max-fixed-arity (-variadic? f)
(every? #(not (fn? (g/get f (str "cljs$core$IFn$_invoke$arity$" %)))) (range 20)))))
(defn -replace-variadic-fn [original-fn n s opts]
(let [accessor "cljs$core$IFn$_invoke$arity$variadic"
arity-fn (g/get original-fn accessor)]
(when arity-fn
(g/set original-fn "malli$instrument$instrumented?" true)
;; the shape of the argument in the following apply calls are needed to match the call style of the cljs compiler
;; so the user's function gets the arguments as expected
(let [max-fixed-arity (-max-fixed-arity original-fn)
instrumented-variadic-fn (m/-instrument opts (fn [& args]
(let [[fixed-args rest-args] (split-at max-fixed-arity (vec args))
final-args (into (vec fixed-args) [(not-empty rest-args)])]
(apply arity-fn final-args))))
instrumented-wrapper (fn [& args]
(let [[fixed-args rest-args] (split-at max-fixed-arity (vec args))
final-args (vec (apply list* (into (vec fixed-args) (not-empty rest-args))))]
(apply instrumented-variadic-fn final-args)))]
(g/set instrumented-wrapper "malli$instrument$original" arity-fn)
(g/set (-get-prop n s) "malli$instrument$instrumented?" true)
(g/set (-get-prop n s) accessor instrumented-wrapper)
(g/set (-get-ns n) s (meta-fn original-fn {:instrumented-symbol (symbol n s)}))))))
(defn -replace-multi-arity [original-fn n s opts]
(let [schema (:schema opts)]
(g/set original-fn "malli$instrument$instrumented?" true)
(g/set (-get-ns n) s (meta-fn original-fn {:instrumented-symbol (symbol n s)}))
(doseq [[arity f-schema] (-arity->schema schema)]
(if (= arity :varargs)
(-replace-variadic-fn original-fn n s opts)
(let [accessor (str "cljs$core$IFn$_invoke$arity$" arity)
arity-fn (g/get original-fn accessor)]
(when arity-fn
(let [instrumented-fn (m/-instrument (assoc opts :schema f-schema) arity-fn)]
(g/set instrumented-fn "malli$instrument$original" arity-fn)
(g/set instrumented-fn "malli$instrument$instrumented?" true)
(g/set (-get-prop n s) accessor instrumented-fn))))))))
(defn -replace-fn [original-fn n s opts]
(try
(cond
(-pure-variadic? original-fn) (-replace-variadic-fn original-fn n s opts)
(-max-fixed-arity original-fn) (-replace-multi-arity original-fn n s opts)
:else (let [instrumented-fn (meta-fn (m/-instrument opts original-fn) {:instrumented-symbol (symbol (name n) (name s))})]
(g/set original-fn "malli$instrument$instrumented?" true)
(g/set instrumented-fn "malli$instrument$instrumented?" true)
(g/set instrumented-fn "malli$instrument$original" original-fn)
(g/set (-get-ns n) (munge (name s)) instrumented-fn)))
(catch :default e
(if (instance? ExceptionInfo e)
(throw
(ex-info
(str "Schema error when instrumenting function: " (symbol (name n) (name s)) " - " (ex-message e))
(ex-data e)))
(throw (js/Error. (str "Schema error when instrumenting function: " (symbol (name n) (name s)) ". " e)))))))
(defn -strument!
([] (-strument! nil))
([{:keys [mode data filters gen report skip-instrumented?] :or {skip-instrumented? false
mode :instrument, data (m/function-schemas :cljs)} :as options}]
(doseq [[n d] data, [s d] d]
(when-let [v (-find-var n s)]
(when (or (not filters) (some #(% n s d) filters))
(case mode
:instrument (let [original-fn (or (-original v) v)
dgen (as-> (select-keys options [:scope :report :gen]) $
(cond-> $ report (update :report (fn [r] (fn [t data] (r t (assoc data :fn-name (symbol (name n) (name s))))))))
(merge $ d)
(cond (and gen (true? (:gen d))) (assoc $ :gen gen)
(true? (:gen d)) (dissoc $ :gen)
:else $))]
(if (and original-fn (not (and skip-instrumented? (-instrumented? v))))
(-replace-fn original-fn n s dgen)))
:unstrument (when (-instrumented? v)
(let [original-fn (or (-original v) v)]
(cond
(-pure-variadic? original-fn)
(let [accessor "cljs$core$IFn$_invoke$arity$variadic"
variadic-fn (g/get v accessor)
orig-variadic-fn (g/get variadic-fn "malli$instrument$original")]
(g/set original-fn accessor orig-variadic-fn))
(-max-fixed-arity original-fn)
(doseq [arity (conj (range 20) "variadic")
:let [accessor (str "cljs$core$IFn$_invoke$arity$" arity)
arity-fn (g/get original-fn accessor)]
:when arity-fn]
(let [orig (g/get arity-fn "malli$instrument$original")]
(g/set original-fn accessor orig)))
:else (g/set (-get-ns n) (munge (name s)) original-fn))))
(mode v d)))))))
;;
;; public api
;;
(defn check
"Checks all registered function schemas using generative testing.
Returns nil or a map of symbol -> explanation in case of errors."
([] (check nil))
([options]
(let [res* (atom {})]
(-strument! (assoc options :mode (fn [v {:keys [schema ns name]}]
(some->> (mg/check schema (-original v))
(swap! res* assoc (symbol ns name))))))
(not-empty @res*))))
(defn instrument!
"Applies instrumentation for a filtered set of function Vars (e.g. `defn`s).
See [[malli.core/-instrument]] for possible options."
([] (instrument! nil))
([options] (-strument! (assoc options :mode :instrument))))
(defn unstrument!
"Removes instrumentation from a filtered set of function Vars (e.g. `defn`s).
See [[malli.core/-instrument]] for possible options."
([] (unstrument! nil))
([options] (-strument! (assoc options :mode :unstrument))))
malli/src/malli/instrument/cljs.clj
Vendored
+251
View File
@@ -0,0 +1,251 @@
(ns ^:deprecated malli.instrument.cljs
(:require [cljs.analyzer.api :as ana-api]
[clojure.walk :as walk]
[malli.core :as m]))
;;
;; CAUTION!!! - THIS NAMESPACE IS DEPRECATED.
;; Please use the malli.instrument namespace from now on.
;;
;;
;; Collect metadata declared function schemas - register them into the known malli.core/-function-schemas* atom based on their metadata.
;;
(defn -collect! [simple-name {:keys [meta] :as var-map}]
(let [ns (symbol (namespace (:name var-map)))
schema (:malli/schema meta)]
(when schema
(let [-qualify-sym (fn [form]
(if (symbol? form)
(if (simple-symbol? form)
(let [ns-data (ana-api/find-ns ns)
intern-keys (set (keys (ana-api/ns-interns ns)))]
(cond
;; a referred symbol
(get-in ns-data [:uses form])
(let [form-ns (str (get-in ns-data [:uses form]))]
(symbol form-ns (str form)))
;; interned var
(contains? intern-keys form)
(symbol (str ns) (str form))
:else
;; a cljs.core var, do not qualify it
form))
(let [ns-part (symbol (namespace form))
name-part (name form)
full-ns (get-in (ana-api/find-ns ns) [:requires ns-part])]
(symbol (str full-ns) name-part)))
form))
schema* (walk/postwalk -qualify-sym schema)
metadata (assoc
(walk/postwalk -qualify-sym (m/-unlift-keys meta "malli"))
:metadata-schema? true)]
(m/-register-function-schema! ns simple-name schema* metadata :cljs identity)
`(do
(m/-register-function-schema! '~ns '~simple-name ~schema* ~metadata :cljs identity)
'~(:name var-map))))))
(defn -sequential [x] (cond (set? x) x (sequential? x) x :else [x]))
(defn -collect!*
[{:keys [ns]}]
(reduce (fn [acc [var-name var-map]] (let [v (-collect! var-name var-map)] (cond-> acc v (conj v))))
#{}
(mapcat (fn [n]
(let [ns-sym (cond (symbol? n) n
;; handles (quote ns-name) - quoted symbols passed to cljs macros show up this way.
(list? n) (second n)
:else (symbol (str n)))]
(ana-api/ns-publics ns-sym)))
(-sequential ns))))
;; intended to be called from a cljs macro
(defn -collect-all-ns []
(-collect!* {:ns (ana-api/all-ns)}))
(defmacro collect-all! [] (-collect-all-ns))
;;
;; instrument
;;
(def -default-schema-keys (set (filter keyword? (keys (m/default-schemas)))))
(defn -mock-cljs-schema
"Takes malli schema data and replaces all non default schemas with :any"
[schema]
(walk/postwalk (fn [form] (if (or (coll? form) (contains? -default-schema-keys form))
form :any))
schema))
(defn -emit-variadic-instrumented-fn [fn-sym schema-map max-fixed-args]
`(set! (.-cljs$core$IFn$_invoke$arity$variadic ~fn-sym)
(let [orig-fn# (.-cljs$core$IFn$_invoke$arity$variadic ~fn-sym)
instrumented# (meta-fn
(m/-instrument ~schema-map
(fn [& args#]
(let [[fixed-args# rest-args#] (split-at ~max-fixed-args (vec args#))]
;; the shape of the argument in this apply call is needed to match the call style of the cljs compiler
;; so the user's function get the arguments as expected
(apply orig-fn# (into (vec fixed-args#) [(not-empty rest-args#)])))))
{:instrumented-symbol '~fn-sym})]
(fn ~(symbol (str (name fn-sym) "-variadic")) [& args#]
(apply instrumented# (apply list* args#))))))
(defn -emit-multi-arity-instrumentation-code
[fn-sym schema-map schema max-fixed-args]
(when-not (= (first schema) :function) (throw (IllegalArgumentException. (str "Multi-arity function " fn-sym " must have :function schema. You provided: "
(pr-str schema)))))
;; Here we pair up each function schema with a mocked version that can safely be parsed in malli Clojure during compilation
;; this is so we can use malli.core helper functions to get the arities for each function schema.
(let [schema-tuples (map (fn [s] [(-mock-cljs-schema s) s]) (rest schema))
arity->schema (into {} (map (fn [[mock-schema schema]]
(let [arity (:arity (m/-function-info (m/schema mock-schema)))]
[arity schema]))
schema-tuples))]
;; ClojureScript produces one JS function per arity, we instrument each one if a schema for that arity is present.
`(do
~@(map (fn [[arity fn-schema]]
(if (= arity :varargs)
(-emit-variadic-instrumented-fn fn-sym schema-map max-fixed-args)
(let [arity-fn-sym `(~(symbol (str ".-cljs$core$IFn$_invoke$arity$" arity)) ~fn-sym)]
`(set! ~arity-fn-sym (meta-fn (m/-instrument ~(assoc schema-map :schema fn-schema) ~arity-fn-sym)
{:instrumented-symbol '~fn-sym})))))
arity->schema))))
(defn -emit-replace-var-code [fn-sym fn-var-meta schema-map schema]
(let [variadic? (-> fn-var-meta :top-fn :variadic?)
max-fixed-args (-> fn-var-meta :top-fn :max-fixed-arity)
; parse arglists, it comes in with this shape: (quote ([a b]))
[_ arglists] (:arglists fn-var-meta)
single-arity? (= (count arglists) 1)]
`(do
(swap! instrumented-vars #(assoc % '~fn-sym ~fn-sym))
~(cond
(and (not variadic?) single-arity?)
`(set! ~fn-sym (meta-fn (m/-instrument ~schema-map ~fn-sym) {:instrumented-symbol '~fn-sym}))
(and variadic? single-arity?)
(-emit-variadic-instrumented-fn fn-sym schema-map max-fixed-args)
;; multi-arity
:else
(-emit-multi-arity-instrumentation-code fn-sym schema-map schema max-fixed-args))
'~fn-sym)))
(defn -emit-instrument-fn [env {:keys [gen filters report] :as instrument-opts}
{:keys [schema] :as schema-map} ns-sym fn-sym]
;; gen is a function
(let [schema-map (-> schema-map
(select-keys [:gen :scope :report])
;; The schema passed in may contain cljs vars that have to be resolved at runtime in cljs.
(assoc :schema `(m/function-schema ~schema))
(cond-> report
(assoc :report `(cljs.core/fn [type# data#] (~report type# (assoc data# :fn-name '~fn-sym))))))
schema-map-with-gen
(as-> (merge (select-keys instrument-opts [:scope :report :gen]) schema-map) $
;; use the passed in gen fn to generate a value
(if (and gen (true? (:gen schema-map)))
(assoc $ :gen gen)
(dissoc $ :gen)))
replace-var-code (when-let [fn-var (ana-api/resolve env fn-sym)]
(-emit-replace-var-code fn-sym (:meta fn-var) schema-map-with-gen schema))]
(if filters
`(when (some #(% '~ns-sym (resolve '~fn-sym) ~schema-map) ~filters)
~replace-var-code)
replace-var-code)))
(defn -instrument [env {:keys [data] :or {data (m/function-schemas :cljs)} :as opts}]
(let [r
(reduce
(fn [acc [ns-sym sym-map]]
(reduce-kv
(fn [acc' fn-sym schema-map]
(conj acc' (-emit-instrument-fn env opts schema-map ns-sym (symbol (str ns-sym) (str fn-sym)))))
acc sym-map)) [] data)]
`(filterv some? ~r)))
;;
;; unstrument
;;
(defn -emit-unstrument-fn [env {:keys [schema filters] :as opts} ns-sym fn-sym]
(let [opts (-> opts
(select-keys [:gen :scope :report])
;; The schema passed in may contain cljs vars that have to be resolved at runtime in cljs.
(assoc :schema `(m/function-schema ~schema)))
replace-with-orig (when (ana-api/resolve env fn-sym)
`(when-let [orig-fn# (get @instrumented-vars '~fn-sym)]
(swap! instrumented-vars #(dissoc % '~fn-sym))
(set! ~fn-sym orig-fn#)
'~fn-sym))]
(if filters
`(when (some #(% '~ns-sym (resolve '~fn-sym) ~opts) ~filters)
~replace-with-orig)
replace-with-orig)))
(defn -unstrument [env opts]
(let [r (reduce
(fn [acc [ns-sym sym-map]]
(reduce-kv
(fn [acc' fn-sym schema-map]
(conj acc' (-emit-unstrument-fn env (assoc opts :schema (:schema schema-map))
ns-sym (symbol (str ns-sym) (str fn-sym)))))
acc sym-map)) [] (m/function-schemas :cljs))]
`(filterv some? ~r)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generative testing, check function return values vs their parameters
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn -emit-check [{:keys [schema]} fn-sym]
`(let [schema# (m/function-schema ~schema)
fn# (or (get @instrumented-vars '~fn-sym) ~fn-sym)]
(when-let [err# (perform-check schema# fn#)]
['~fn-sym err#])))
(defn -check []
(let [r (reduce (fn [acc [ns-sym sym-map]]
(reduce-kv (fn [acc' fn-sym schema-map]
(conj acc' (-emit-check schema-map (symbol (str ns-sym) (str fn-sym)))))
acc sym-map)) [] (m/function-schemas :cljs))]
`(into {} ~r)))
;;
;; public api
;;
(defmacro check
"Checks all registered function schemas using generative testing.
Returns nil or a map of symbol -> explanation in case of errors."
[] (-check))
(defmacro collect!
"Reads all public Vars from a given namespace(s) and registers a function (var) schema if `:malli/schema`
metadata is present. The following metadata key can be used:
| key | description |
| ----------------|-------------|
| `:malli/schema` | function schema
| `:malli/scope` | optional set of scope definitions, defaults to `#{:input :output}`
| `:malli/report` | optional side-effecting function of `key data -> any` to report problems, defaults to `m/-fail!`
| `:malli/gen` | optional value `true` or function of `schema -> schema -> value` to be invoked on the args to get the return value"
([] `(collect! ~{:ns (symbol (str *ns*))}))
([args-map] (-collect!* args-map)))
(defmacro instrument!
"Applies instrumentation for a filtered set of function Vars (e.g. `defn`s).
See [[malli.core/-instrument]] for possible options."
([] (-instrument &env {}))
([opts] (-instrument &env opts)))
(defmacro unstrument!
"Removes instrumentation from a filtered set of function Vars (e.g. `defn`s).
See [[malli.core/-instrument]] for possible options."
([] (-unstrument &env {}))
([opts] (-unstrument &env opts)))
malli/src/malli/instrument/cljs.cljs
Vendored
+20
View File
@@ -0,0 +1,20 @@
(ns malli.instrument.cljs
(:require-macros [malli.instrument.cljs])
(:require [malli.generator :as mg]))
(defonce instrumented-vars (atom {}))
(defn -filter-var [f] (fn [_ s _] (f s)))
(defn -filter-ns [& ns] (fn [n _ _] ((set ns) n)))
(defn meta-fn
;; Taken from https://clojure.atlassian.net/browse/CLJS-3018
;; Because the current MetaFn implementation can cause quirky errors in CLJS
[f m]
(let [new-f (goog/bind f #js{})]
(js/Object.assign new-f f)
(specify! new-f IMeta #_:clj-kondo/ignore (-meta [_] m))
new-f))
(defn perform-check [schema f]
(mg/check schema f))
malli/src/malli/json_schema.cljc
Vendored
+222
View File
@@ -0,0 +1,222 @@
(ns malli.json-schema
(:require [clojure.set :as set]
[clojure.string :as str]
[malli.core :as m]))
(declare -transform)
(defprotocol JsonSchema
(-accept [this children options] "transforms schema to JSON Schema"))
(defn -join-ref [prefix suffix]
;; kludge to make :foo.bar/quux and :foo/bar.quux not collide
(str prefix
(if (str/includes? (str suffix) ".") ".." ".")
suffix))
(defn -ref [schema {::keys [transform definitions definitions-path]
:or {definitions-path "#/definitions/"}
:as options}]
(let [ref (as-> (m/-ref schema) $
(cond (var? $) (let [{:keys [ns name]} (meta $)]
(-join-ref ns name))
(qualified-ident? $) (-join-ref (namespace $) (name $))
:else (str $)))]
(when-not (contains? @definitions ref)
(let [child (m/deref schema)]
(swap! definitions assoc ref ::recursion-stopper)
(swap! definitions assoc ref (transform child options))))
;; '/' must be encoded as '~1' in JSON Schema - https://www.rfc-editor.org/rfc/rfc6901
;; However, tools like openapi-schema-validator disallow ~1, so we use "." as the separator above.
;; This str/replace is left here in case a user has managed to smuggle a "/" in to the type name.
{:$ref (apply str definitions-path (str/replace ref #"/" "~1"))}))
(defn -schema [schema {::keys [transform] :as options}]
(if (m/-ref schema)
(-ref schema options)
(transform (m/deref schema) options)))
(defn select [m] (select-keys m [:title :description :default]))
(defmulti accept (fn [name _schema _children _options] name) :default ::default)
(defmethod accept ::default [_ _ _ _] {})
(defmethod accept 'any? [_ _ _ _] {})
(defmethod accept 'some? [_ _ _ _] {})
(defmethod accept 'number? [_ _ _ _] {:type "number"})
(defmethod accept 'integer? [_ _ _ _] {:type "integer"})
(defmethod accept 'int? [_ _ _ _] {:type "integer"})
(defmethod accept 'pos-int? [_ _ _ _] {:type "integer", :minimum 1})
(defmethod accept 'neg-int? [_ _ _ _] {:type "integer", :maximum -1})
(defmethod accept 'nat-int? [_ _ _ _] {:type "integer", :minimum 0})
(defmethod accept 'float? [_ _ _ _] {:type "number"})
(defmethod accept 'double? [_ _ _ _] {:type "number"})
(defmethod accept 'float? [_ _ _ _] {:type "number"})
(defmethod accept 'pos? [_ _ _ _] {:type "number" :exclusiveMinimum 0})
(defmethod accept 'neg? [_ _ _ _] {:type "number" :exclusiveMaximum 0})
(defmethod accept 'boolean? [_ _ _ _] {:type "boolean"})
(defmethod accept 'string? [_ _ _ _] {:type "string"})
(defmethod accept 'ident? [_ _ _ _] {:type "string"})
(defmethod accept 'simple-ident? [_ _ _ _] {:type "string"})
(defmethod accept 'qualified-ident? [_ _ _ _] {:type "string"})
(defmethod accept 'keyword? [_ _ _ _] {:type "string"})
(defmethod accept 'simple-keyword? [_ _ _ _] {:type "string"})
(defmethod accept 'qualified-keyword? [_ _ _ _] {:type "string"})
(defmethod accept 'symbol? [_ _ _ _] {:type "string"})
(defmethod accept 'simple-symbol? [_ _ _ _] {:type "string"})
(defmethod accept 'qualified-symbol? [_ _ _ _] {:type "string"})
(defmethod accept 'uuid? [_ _ _ _] {:type "string" :format "uuid"})
(defmethod accept 'uri? [_ _ _ _] {:type "string" :format "uri"})
(defmethod accept 'decimal? [_ _ _ _] {:type "number"})
(defmethod accept 'inst? [_ _ _ _] {:type "string" :format "date-time"})
(defmethod accept 'seqable? [_ _ _ _] {:type "array"})
(defmethod accept 'indexed? [_ _ _ _] {:type "array"})
(defmethod accept 'map? [_ _ _ _] {:type "object"})
(defmethod accept 'vector? [_ _ _ _] {:type "array"})
(defmethod accept 'list? [_ _ _ _] {:type "array"})
(defmethod accept 'seq? [_ _ _ _] {:type "array"})
(defmethod accept 'char? [_ _ _ _] {:type "string"})
(defmethod accept 'set? [_ _ _ _] {:type "array" :uniqueItems true})
(defmethod accept 'nil? [_ _ _ _] {:type "null"})
(defmethod accept 'false? [_ _ _ _] {:type "boolean"})
(defmethod accept 'true? [_ _ _ _] {:type "boolean"})
(defmethod accept 'zero? [_ _ _ _] {:type "integer"})
#?(:clj (defmethod accept 'rational? [_ _ _ _] {:type "number"}))
(defmethod accept 'coll? [_ _ _ _] {:type "object"})
(defmethod accept 'empty? [_ _ _ _] {:type "array" :maxItems 0 :minItems 0})
(defmethod accept 'associative? [_ _ _ _] {:type "object"})
(defmethod accept 'sequential? [_ _ _ _] {:type "array"})
#?(:clj (defmethod accept 'ratio? [_ _ _ _] {:type "number"}))
(defmethod accept 'bytes? [_ _ _ _] {:type "string" :format "byte"})
(defmethod accept 'ifn? [_ _ _ _] {})
(defmethod accept 'fn? [_ _ _ _] {})
(defmethod accept :> [_ _ [value] _] {:type "number" :exclusiveMinimum value})
(defmethod accept :>= [_ _ [value] _] {:type "number" :minimum value})
(defmethod accept :< [_ _ [value] _] {:type "number" :exclusiveMaximum value})
(defmethod accept :<= [_ _ [value] _] {:type "number" :maximum value})
(defmethod accept := [_ _ [value] _] {:const value})
(defmethod accept :not= [_ _ _ _] {})
(defmethod accept :not [_ _ children _] {:not (last children)})
(defmethod accept :and [_ _ children _] {:allOf children})
(defmethod accept :andn [_ _ children _] {:allOf (map last children)})
(defmethod accept :or [_ _ children _] {:anyOf children})
(defmethod accept :orn [_ _ children _] {:anyOf (map last children)})
(defmethod accept ::m/val [_ _ children _] (first children))
(defmethod accept :map [_ schema children _]
(let [ks (set (m/explicit-keys schema))
default (some->> children (remove (m/-comp ks first)) first last)
{additionalProperties' :additionalProperties properties' :properties required' :required} default
children (filter (m/-comp ks first) children)
required (->> children (filter (m/-comp not :optional second)) (mapv first))
closed (:closed (m/properties schema))
object {:type "object"
:properties (apply array-map (mapcat (fn [[k _ s]] [k s]) children))}]
(cond-> (merge default object)
(seq required) (assoc :required required)
closed (assoc :additionalProperties false)
default (cond->
additionalProperties' (assoc :additionalProperties additionalProperties')
properties' (update :properties merge properties')
required' (update :required (comp vec distinct into) required')))))
(defmethod accept :multi [_ _ children _] {:oneOf (mapv last children)})
(defn- minmax-properties [m schema kmin kmax]
(merge m (-> schema (m/properties) (select-keys [:min :max]) (set/rename-keys {:min kmin, :max kmax}))))
(defmethod accept :map-of [_ schema children _]
(minmax-properties
{:type "object",
:additionalProperties (second children)}
schema
:minProperties
:maxProperties))
(defmethod accept :vector [_ schema children _]
(minmax-properties
{:type "array", :items (first children)}
schema
:minItems
:maxItems))
(defmethod accept :sequential [_ schema children _]
(minmax-properties
{:type "array", :items (first children)}
schema
:minItems
:maxItems))
(defmethod accept :set [_ schema children _]
(minmax-properties
{:type "array", :items (first children), :uniqueItems true}
schema
:minItems
:maxItems))
(defmethod accept :enum [_ _ children options] (merge (some-> (m/-infer children) (-transform options)) {:enum children}))
(defmethod accept :maybe [_ _ children _] {:oneOf (conj children {:type "null"})})
(defmethod accept :tuple [_ _ children _] {:type "array", :prefixItems children, :items false})
(defmethod accept :re [_ schema _ options] {:type "string", :pattern (first (m/children schema options))})
(defmethod accept :fn [_ _ _ _] {})
(defmethod accept :any [_ _ _ _] {})
(defmethod accept :some [_ _ _ _] {})
(defmethod accept :nil [_ _ _ _] {:type "null"})
(defmethod accept :string [_ schema _ _]
(merge {:type "string"} (-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minLength, :max :maxLength}))))
(defmethod accept :int [_ schema _ _]
(merge {:type "integer"} (-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defmethod accept :float [_ schema _ _]
(merge {:type "number"}
(-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defmethod accept :double [_ schema _ _]
(merge {:type "number"}
(-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defmethod accept :boolean [_ _ _ _] {:type "boolean"})
(defmethod accept :keyword [_ _ _ _] {:type "string"})
(defmethod accept :qualified-keyword [_ _ _ _] {:type "string"})
(defmethod accept :symbol [_ _ _ _] {:type "string"})
(defmethod accept :qualified-symbol [_ _ _ _] {:type "string"})
(defmethod accept :uuid [_ _ _ _] {:type "string" :format "uuid"})
(defmethod accept :=> [_ _ _ _] {})
(defmethod accept :function [_ _ _ _] {})
(defmethod accept :ref [_ schema _ options] (-ref schema options))
(defmethod accept :schema [_ schema _ options] (-schema schema options))
(defmethod accept ::m/schema [_ schema _ options] (-schema schema options))
(defmethod accept :merge [_ schema _ {::keys [transform] :as options}] (transform (m/deref schema) options))
(defmethod accept :union [_ schema _ {::keys [transform] :as options}] (transform (m/deref schema) options))
(defmethod accept :select-keys [_ schema _ {::keys [transform] :as options}] (transform (m/deref schema) options))
(defn- -json-schema-walker [schema _ children options]
(let [p (merge (m/type-properties schema) (m/properties schema))]
(or (get p :json-schema)
(merge (select p)
(if (satisfies? JsonSchema schema)
(-accept schema children options)
(accept (m/type schema) schema children options))
(m/-unlift-keys p :json-schema)))))
(defn -transform [?schema options] (m/walk ?schema -json-schema-walker options))
;;
;; public api
;;
(defn transform
([?schema]
(transform ?schema nil))
([?schema options]
(let [definitions (atom {})
options (merge options {::m/walk-entry-vals true, ::definitions definitions, ::transform -transform})]
(cond-> (-transform ?schema options) (seq @definitions) (assoc :definitions @definitions)))))
malli/src/malli/plantuml.cljc
Vendored
+21
View File
@@ -0,0 +1,21 @@
(ns malli.plantuml
(:require [clojure.string :as str]
[malli.core :as m]
[malli.dot :as md]))
(defn transform
([?schema] (transform ?schema nil))
([?schema options]
(let [registry (-> ?schema (m/schema options) md/-lift md/-collect md/-normalize :registry)
entity? #(->> % (get registry) m/properties ::md/entity not)
sorted #(sort-by (m/-comp str first) %)]
(with-out-str
(println "@startuml")
(doseq [[k v] (sorted registry)]
(println (if (entity? k) "entity" "abstract") k "{\n"
(or (some->> (m/entries v) (map (fn [[k s]] (str (pr-str k) " " (pr-str (m/form (m/deref s)))))) (str/join "\n "))
(pr-str (m/form v))))
(println "}"))
(doseq [[from tos] (sorted (md/-get-links registry)), to tos]
(println from (if (entity? to) "o--" "*--") to))
(println "@enduml")))))
malli/src/malli/provider.cljc
Vendored
+111
View File
@@ -0,0 +1,111 @@
(ns malli.provider
(:require [malli.core :as m]
[malli.registry :as mr]))
(def -preferences (-> [:int 'integer? :double :float 'number? :qualified-keyword :keyword :symbol :string :boolean :uuid 'inst?]
(reverse) (zipmap (drop 1 (range))) (assoc 'any? -14 'some? -13, :or -12, :and -11, :any -10, :some -9)))
(defn -safe? [f & args] (try (apply f args) (catch #?(:clj Exception, :cljs js/Error) _ false)))
(defrecord Hinted [value hint])
(defn -hinted [x hint] (->Hinted x hint))
(defn -value-hint [x] (if (instance? Hinted x) [(:value x) (:hint x)] [x (some-> x meta ::hint)]))
(defn -inferrer [options]
(let [schemas (->> options (m/-registry) (mr/-schemas) (vals) (filter #(-safe? m/schema %)))
form->validator (into {} (mapv (juxt m/form m/validator) schemas))
infer-value (fn [x] (-> (reduce-kv (fn [acc f v] (cond-> acc (-safe? v x) (assoc f 1))) {} form->validator)))
entry-inferrer (fn [infer] (fn [acc k v] (update acc :keys update k infer v)))
infer-map (fn [infer] (fn [acc x] (update (reduce-kv (entry-inferrer infer) acc x) :data (fnil conj []) x)))
infer-seq (fn [infer] (fn [acc x] (update (reduce infer acc x) :data (fnil conj []) x)))
merge+ (fnil #(merge-with + %1 %2) {})]
(fn infer [acc x]
(let [[x hint] (-value-hint x)
type (cond (nil? x) :nil
(map? x) :map
(set? x) :set
(vector? x) :vector
(sequential? x) :sequential
:else :value)
->type #(as-> (update % :count (fnil inc 0)) $
(cond-> $ hint (update :hints (fnil conj #{}) hint))
(case type
(:value :nil) (-> $ (update :values merge+ {x 1}) (update :schemas merge+ (infer-value x)))
:map ((infer-map infer) $ x)
(:set :vector :sequential) (update $ :values (fnil (infer-seq infer) {}) x)))]
(-> acc (update :count (fnil inc 0)) (update :types update type ->type))))))
(defn -value-schema [{:keys [schemas hints] :as stats}]
(or (when-let [hint (and (= 1 (count hints)) (first hints))]
(case hint :enum (into [:enum] (keys (:values stats))), hint))
(let [max (->> schemas vals (apply max))]
(->> schemas (filter #(= max (val %))) (map (fn [[k]] [k (-preferences k -1)])) (sort-by second >) (ffirst)))))
(defn -sequential-schema [{tc :count :as stats} type schema {:keys [::infer ::tuple-threshold] :as options}]
(let [vstats* (delay (-> stats :types type))
data* (delay (-> @vstats* :values :data))
vs* (delay (map (fn [x] (map #(schema (infer {} %)) x)) @data*))
tuple?* (delay (apply = (map count @vs*)))]
(or (and (= :vector type)
(or (when (and (some-> @vstats* :hints (= #{:tuple})) @tuple?*)
(into [:tuple] (map #(schema (reduce infer {} %) options) (apply map vector @data*))))
(when-let [tuple-threshold (when (and tuple-threshold (= tc (:count @vstats*))) tuple-threshold)]
(when (and (>= tc tuple-threshold) @tuple?*)
(when (apply = @vs*) (into [:tuple] (first @vs*)))))))
[type (-> @vstats* :values (schema options))])))
(defn -map-of-accept [stats]
(let [ks (->> stats :data (mapcat keys))] (> (count (distinct ks)) (Math/pow (count ks) 0.7))))
(defn -map-schema [{tc :count :as stats} schema {:keys [::infer ::map-of-threshold ::map-of-accept] :or {map-of-accept -map-of-accept} :as options}]
(let [entries (map (fn [[key vstats]] {:key key, :vs (schema vstats options), :vc (:count vstats)}) (:keys stats))
ks* (delay (schema (reduce infer {} (map :key entries)) options))
?ks* (delay (let [kss (map #(schema (infer {} (:key %)) options) entries)] (when (apply = kss) (first kss))))
vs* (delay (schema (reduce infer {} (->> stats :data (mapcat vals))) options))
vss (map :vs entries)]
(or (when (some-> stats :hints (= #{:map-of})) [:map-of @ks* @vs*])
(when (and (some->> map-of-threshold (>= tc)) @?ks* (apply = vss) (map-of-accept stats)) [:map-of @?ks* (first vss)])
(into [:map] (map (fn [{:keys [key vs vc]}] (if (not= tc vc) [key {:optional true} vs] [key vs])) entries)))))
(defn -decoded [{:keys [values]} vp t]
(let [vs (keys values), << (fn [f] (reduce (fn [_ v] (let [v' (f v)] (or (not= v v') (reduced false)))) false vs))]
(reduce-kv (fn [acc s f] (if (<< f) (reduced s) acc)) t vp)))
(defn -schema
([stats] (-schema stats nil))
([{:keys [types] :as stats} {:keys [::value-decoders] :as options}]
(cond (= 1 (count (keys types))) (let [type (-> types keys first)]
(case type
:nil :nil
:value (let [t (type types), vs (-value-schema t), vp (get value-decoders vs)]
(cond->> vs vp (-decoded t vp)))
(:set :vector :sequential) (-sequential-schema stats type -schema options)
:map (-map-schema (type types) -schema options)))
(nil? types) :any
:else (let [children (map (fn [[type]] (-schema (update stats :types select-keys [type]) options)) types)
without-nils (remove #(= % :nil) children)
[c1 c2] (map count [children without-nils])]
(cond (= 1 c2) (into [:maybe] without-nils)
(not= c1 c2) [:maybe (into [:or] without-nils)]
:else (into [:or] children))))))
;;
;; public api
;;
(defn provider
"Returns a inferring function of `values -> schema`. Supports the following options:
- `:malli.provider/tuple-threshold, how many identical value schemas need for :tuple
- `:malli.provider/map-of-threshold, how many identical value schemas need for :map-of
- `:malli.provider/map-of-accept, function of type `stats -> boolean` to identify :map-of
- `:malli.provider/value-decoders, function of `type -> target-type -> value -> decoded-value`"
([] (provider nil))
([options] (let [infer (-inferrer options)]
(fn [xs] (-> (reduce infer {} xs) (-schema (assoc options ::infer infer)))))))
(defn provide
"Given an sequence of example values, returns a Schema that can all values are valid against.
For better performance, use [[provider]] instead. See [[provider]] for available options."
([xs] (provide xs nil))
([xs options] ((provider options) xs)))
malli/src/malli/registry.cljc
Vendored
+105
View File
@@ -0,0 +1,105 @@
(ns malli.registry
(:refer-clojure :exclude [type])
#?(:clj (:import (java.util HashMap Map))))
#?(:cljs (goog-define mode "default")
:clj (def mode (or (System/getProperty "malli.registry/mode") "default")))
#?(:cljs (goog-define type "default")
:clj (def type (or (System/getProperty "malli.registry/type") "default")))
(defprotocol Registry
(-schema [this type] "returns the schema from a registry")
(-schemas [this] "returns all schemas from a registry"))
(defn registry? [x] (#?(:clj instance?, :cljs implements?) malli.registry.Registry x))
(defn fast-registry [m]
(let [fm #?(:clj (doto (HashMap. 1024 0.25) (.putAll ^Map m)), :cljs m)]
(reify
Registry
(-schema [_ type] (.get fm type))
(-schemas [_] m))))
(defn simple-registry [m]
(reify
Registry
(-schema [_ type] (m type))
(-schemas [_] m)))
(defn registry [?registry]
(cond (nil? ?registry) nil
(registry? ?registry) ?registry
(map? ?registry) (simple-registry ?registry)
(satisfies? Registry ?registry) ?registry))
;;
;; custom
;;
(def ^:private registry* (atom (simple-registry {})))
(defn set-default-registry! [?registry]
(if-not #?(:cljs (identical? mode "strict")
:default (= mode "strict"))
(reset! registry* (registry ?registry))
(throw (ex-info "can't set default registry, invalid mode" {:mode mode, :type type}))))
(defn ^:no-doc custom-default-registry []
(reify
Registry
(-schema [_ type] (-schema @registry* type))
(-schemas [_] (-schemas @registry*))))
(defn composite-registry [& ?registries]
(let [registries (mapv registry ?registries)]
(reify
Registry
(-schema [_ type] (some #(-schema % type) registries))
(-schemas [_] (reduce merge (map -schemas (reverse registries)))))))
(defn mutable-registry [db]
(reify
Registry
(-schema [_ type] (-schema (registry @db) type))
(-schemas [_] (-schemas (registry @db)))))
(defn var-registry []
(reify
Registry
(-schema [_ type] (if (var? type) @type))
(-schemas [_])))
(def ^:dynamic *registry* {})
(defn dynamic-registry []
(reify
Registry
(-schema [_ type] (-schema (registry *registry*) type))
(-schemas [_] (-schemas (registry *registry*)))))
(defn lazy-registry [default-registry provider]
(let [cache* (atom {})
registry* (atom default-registry)]
(reset!
registry*
(composite-registry
default-registry
(reify
Registry
(-schema [_ name]
(or (@cache* name)
(when-let [schema (provider name @registry*)]
(swap! cache* assoc name schema)
schema)))
(-schemas [_] @cache*))))))
(defn schema
"finds a schema from a registry"
[registry type]
(-schema registry type))
(defn schemas
"finds all schemas from a registry"
[registry]
(-schemas registry))
malli/src/malli/sci.cljc
Vendored
+16
View File
@@ -0,0 +1,16 @@
(ns malli.sci
(:require [borkdude.dynaload :as dynaload]))
(defn evaluator [options fail!]
#?(:bb (fn []
(fn [form]
(load-string (str "(ns user (:require [malli.core :as m]))\n" form))))
:default (let [eval-string* (dynaload/dynaload 'sci.core/eval-string* {:default nil})
init (dynaload/dynaload 'sci.core/init {:default nil})
fork (dynaload/dynaload 'sci.core/fork {:default nil})]
(fn [] (if (and @eval-string* @init @fork)
(let [ctx (init options)]
(eval-string* ctx "(alias 'm 'malli.core)")
(fn eval [s]
(eval-string* (fork ctx) (str s))))
fail!)))))
malli/src/malli/swagger.cljc
Vendored
+213
View File
@@ -0,0 +1,213 @@
(ns malli.swagger
(:require [clojure.set :as set]
[clojure.walk :as walk]
[malli.core :as m]
[malli.json-schema :as json-schema]))
(defprotocol SwaggerSchema
(-accept [this children options] "transforms schema to Swagger Schema"))
(defmulti accept (fn [name _schema _children _options] name) :default ::default)
(defmethod accept ::default [name schema children options] (json-schema/accept name schema children options))
(defmethod accept 'nil? [_ _ _ _] {})
(defmethod accept :not [_ _ children _] {:x-not (first children)})
(defn -base [s children]
(or (some #(when (not= "null" (:type %))
%)
children)
(m/-fail! ::non-null-base-needed {:schema s})))
(defmethod accept :and [_ s children _]
(let [base (-base s children)]
(assoc base :x-allOf children)))
(defmethod accept :andn [_ s children _]
(let [children (map last children)
base (-base s children)]
(assoc base :x-allOf children)))
(defmethod accept :or [_ s children _]
(let [base (-base s children)]
(assoc base :x-anyOf children)))
(defmethod accept :orn [_ s children _]
(let [children (map last children)
base (-base s children)]
(assoc base :x-anyOf children)))
(defmethod accept :multi [_ s children _]
(let [cs (mapv last children)
base (-base s cs)]
(assoc base :x-anyOf cs)))
(defmethod accept :maybe [_ s children {:keys [type in]}]
(let [k (if (and (= type :parameter) (not= in :body)) :allowEmptyValue :x-nullable)
base (-base s children)]
(assoc base k true)))
(defmethod accept :tuple [_ _ children _] {:type "array" :items {} :x-items children})
;; Number formats are only defined in Swagger/OpenAPI spec.
(defmethod accept 'number? [_ _ _ _] {:type "number" :format "double"})
(defmethod accept 'integer? [_ _ _ _] {:type "integer" :format "int32"})
(defmethod accept 'int? [_ _ _ _] {:type "integer" :format "int64"})
(defmethod accept 'pos-int? [_ _ _ _] {:type "integer", :format "int64", :minimum 1})
(defmethod accept 'neg-int? [_ _ _ _] {:type "integer", :format "int64", :maximum -1})
(defmethod accept 'nat-int? [_ _ _ _] {:type "integer", :format "int64" :minimum 0})
(defmethod accept 'float? [_ _ _ _] {:type "number" :format "float"})
(defmethod accept 'double? [_ _ _ _] {:type "number" :format "double"})
(defmethod accept :int [_ schema _ _]
(merge {:type "integer" :format "int64"}
(-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defmethod accept :double [_ schema _ _]
(merge {:type "number" :format "double"}
(-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))
(defn- -swagger-walker [schema _ children options]
(let [p (merge (m/type-properties schema) (m/properties schema))]
(or (get p :swagger)
(get p :json-schema)
(merge (json-schema/select p)
(if (satisfies? SwaggerSchema schema)
(-accept schema children options)
(accept (m/type schema) schema children options))
(m/-unlift-keys p :json-schema)
(m/-unlift-keys p :swagger)))))
(defn -transform [?schema options] (m/walk ?schema -swagger-walker options))
(defn -remove-empty-keys
[m]
(into (empty m) (filter (comp not nil? val) m)))
;;
;; public api
;;
(defn transform
([?schema]
(transform ?schema nil))
([?schema options]
(let [definitions (atom {})
options (merge options {::m/walk-entry-vals true
::json-schema/definitions definitions
::json-schema/transform -transform})
t (-transform ?schema options)]
(when (= "null" (:type t))
(m/-fail! ::non-null-base-needed {:schema (m/form ?schema options)}))
(cond-> t (seq @definitions) (assoc :definitions @definitions)))))
(defmulti extract-parameter (fn [in _] in))
(defmethod extract-parameter :body [_ schema]
(let [swagger-schema (transform schema {:in :body, :type :parameter})]
[{:in "body"
:name (:title swagger-schema "body")
:description (:description swagger-schema "")
:required (not= :maybe (m/type schema))
:schema swagger-schema}]))
(defmethod extract-parameter :default [in schema]
;; We can't have a $ref on the top level since we are only
;; interested in the properties of the top-level schema.
;; We also can't have a $ref on the second level, because it would
;; mean overwriting the whole {:in i :name k ...} map
;; ($ref replaces the whole object it is in).
;;
;; Until we come up with a usecase for $refs inside non-:body
;; parameters, let's just deref-recursive here.
(let [{:keys [properties required]} (transform (m/deref-recursive schema) {:in in, :type :parameter})]
(mapv
(fn [[k {:keys [type] :as schema}]]
(merge
{:in (name in)
:name k
:description (:description schema "")
:type type
:required (contains? (set required) k)}
schema))
properties)))
(defmulti expand (fn [k _ _ _] k))
(defmethod expand ::responses [_ v acc _]
{:responses
(into
(or (:responses acc) {})
(for [[status response] v]
[status (cond-> response
(:schema response) (update :schema transform {:type :schema})
true (update :description (fnil identity ""))
true -remove-empty-keys)]))})
(defmethod expand ::parameters [_ v acc _]
(let [old (or (:parameters acc) [])
new (mapcat (fn [[in spec]] (extract-parameter in spec)) v)
merged (->> (into old new)
reverse
(reduce
(fn [[ps cache :as acc] p]
(let [c (select-keys p [:in :name])]
(if (cache c)
acc
[(conj ps p) (conj cache c)])))
[[] #{}])
first
reverse
vec)]
{:parameters merged}))
(defn dissoc-non-root-definitions
[{:keys [parameters responses] :as x}]
(cond-> x
parameters (update :parameters
#(mapv (fn [p]
(if (contains? p :schema)
(update p :schema dissoc :definitions)
p))
%))
responses (update :responses
#(reduce-kv (fn [rs k v]
(assoc rs k
(if (contains? v :schema)
(update v :schema
dissoc :definitions)
v)))
{} %))))
(defn expand-qualified-keywords
[x options]
(let [accept? (-> expand methods keys set)]
(walk/postwalk
(fn [x]
(if (map? x)
(reduce-kv
(fn [acc k v]
(if (accept? k)
(let [expanded (expand k v acc options)
parameters (:parameters expanded)
responses (:responses expanded)
definitions (apply merge
(:definitions acc)
(concat
(->> responses vals (map (comp :definitions :schema)))
(->> parameters (map (comp :definitions :schema)))))]
(-> acc (dissoc k) (merge expanded)
(merge (when-not (empty? definitions) [:definitions definitions]))
dissoc-non-root-definitions))
acc))
x x)
x))
x)))
(defn swagger-spec
([x]
(swagger-spec x nil))
([x options]
(expand-qualified-keywords x options)))
malli/src/malli/transform.cljc
Vendored
+529
View File
@@ -0,0 +1,529 @@
(ns malli.transform
#?(:cljs (:refer-clojure :exclude [Inst Keyword UUID]))
(:require [malli.core :as m]
[malli.util :as mu]
[clojure.math :as math]
#?(:cljs [goog.date.UtcDateTime])
#?(:cljs [goog.date.Date]))
#?(:clj (:import (java.time Instant ZoneId)
(java.time.format DateTimeFormatter DateTimeFormatterBuilder)
(java.time.temporal ChronoField)
(java.net URI)
(java.util Date UUID))))
(def ^:dynamic *max-compile-depth* 10)
(defn -interceptor
"Utility function to convert input into an interceptor. Works with functions,
map and sequence of those."
[?interceptor schema options]
(cond
(fn? ?interceptor)
{:enter ?interceptor}
(and (map? ?interceptor) (contains? ?interceptor :compile))
(let [compiled (::compiled options 0)
options (assoc options ::compiled (inc ^long compiled))]
(when (>= ^long compiled ^long *max-compile-depth*)
(m/-fail! ::too-deep-compilation {:this ?interceptor, :schema schema, :options options}))
(when-let [interceptor (-interceptor ((:compile ?interceptor) schema options) schema options)]
(merge
(dissoc ?interceptor :compile)
interceptor)))
(and (map? ?interceptor)
(or (contains? ?interceptor :enter)
(contains? ?interceptor :leave))) ?interceptor
(coll? ?interceptor)
(reduce
(fn [{:keys [enter leave]} {new-enter :enter new-leave :leave}]
(let [enter (if (and enter new-enter) #(new-enter (enter %)) (or enter new-enter))
leave (if (and leave new-leave) #(leave (new-leave %)) (or leave new-leave))]
{:enter enter :leave leave}))
(keep #(-interceptor % schema options) ?interceptor))
(nil? ?interceptor) nil
(ifn? ?interceptor)
{:enter ?interceptor}
:else (m/-fail! ::invalid-transformer {:value ?interceptor})))
(defn -safe [f] #(try (f %) (catch #?(:clj Exception, :cljs js/Error) _ %)))
;;
;; from strings
;;
(defn -string->long [x]
(if (string? x)
(try #?(:clj (Long/parseLong x)
:cljs (let [x' (if (re-find #"\D" (subs x 1)) ##NaN (js/parseInt x 10))]
(cond
(js/isNaN x') x
(> x' js/Number.MAX_SAFE_INTEGER) x
(< x' js/Number.MIN_SAFE_INTEGER) x
:else x')))
(catch #?(:clj Exception, :cljs js/Error) _ x))
x))
(defn parse-float [s]
#?(:clj
(if (string? s)
(try
(Float/parseFloat s)
(catch NumberFormatException _ nil))
(throw (IllegalArgumentException.
(str "Expected string, got " (if (nil? s) "nil" (-> s class .getName))))))
:cljs
(parse-double s)))
(defn -string->float [x]
(if (string? x)
(or (parse-float x) x)
x))
(defn -string->double [x]
(if (string? x)
(or (parse-double x) x)
x))
(defn -number->float [x]
(if (number? x) (float x) x))
(defn -number->double [x]
(if (number? x) (double x) x))
(defn -number->long [x]
(cond
(integer? x) x
(and (number? x) (== x (math/round x))) (math/round x)
:else x))
(defn -string->keyword [x]
(if (string? x) (keyword x) x))
(defn -string->boolean [x]
(if (string? x)
(cond (= "true" x) true
(= "false" x) false
:else x)
x))
(def ^:private uuid-re
#"(?i)^[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}$")
(defn -string->uuid [x]
(if (string? x)
(if-let [x (re-matches uuid-re x)]
#?(:clj (UUID/fromString x)
:cljs (uuid x))
x)
x))
#?(:clj
(defn -string->uri [x]
(if (string? x)
(try
(URI. x)
;; TODO replace with URISyntaxException once we are on
;; babashka >= v1.3.186.
(catch Exception _
x))
x)))
#?(:clj
(def ^DateTimeFormatter +string->date-format+
(-> (DateTimeFormatterBuilder.)
(.appendPattern "yyyy-MM-dd['T'HH:mm:ss]")
(.optionalStart)
(.appendFraction ChronoField/MICRO_OF_SECOND, 0, 9, true)
(.optionalEnd)
(.optionalStart)
(.appendOffset "+HHMMss", "Z")
(.optionalEnd)
(.optionalStart)
(.appendOffset "+HH:MM:ss", "Z")
(.optionalEnd)
(.parseDefaulting ChronoField/HOUR_OF_DAY 0)
(.parseDefaulting ChronoField/OFFSET_SECONDS 0)
(.toFormatter))))
(defn -string->date [x]
(if (string? x)
(try #?(:clj (Date/from (Instant/from (.parse +string->date-format+ x)))
:cljs (js/Date. (.getTime (goog.date.UtcDateTime/fromIsoString x))))
(catch #?(:clj Exception, :cljs js/Error) _ x))
x))
#?(:clj
(defn -string->decimal [x]
(if (string? x)
(try (BigDecimal. ^String x)
(catch Exception _ x))
x)))
(defn -string->symbol [x]
(if (string? x) (symbol x) x))
(defn -string->nil [x]
(if (= "" x) nil x))
;;
;; misc
;;
(defn -any->string [x]
(when-not (nil? x) (str x)))
(defn -any->any [x] x)
#?(:clj
(def ^DateTimeFormatter +date->string-format+
(-> (DateTimeFormatter/ofPattern "yyyy-MM-dd'T'HH:mm:ss.SSSXXX")
(.withZone (ZoneId/of "UTC")))))
(defn -date->string [x]
(if (inst? x)
(try #?(:clj (.format +date->string-format+ (Instant/ofEpochMilli (inst-ms x)))
:cljs (.toISOString x))
(catch #?(:clj Exception, :cljs js/Error) _ x))
x))
(defn -transform-map-keys
([f]
(let [xform (map (fn [[k v]] [(f k) v]))]
#(cond->> % (map? %) (into (empty %) xform))))
([ks f]
(let [xform (map (fn [[k v]] [(cond-> k (contains? ks k) f) v]))]
#(cond->> % (map? %) (into (empty %) xform)))))
(defn -transform-if-valid [f schema]
(let [validator (m/-validator schema)]
(fn [x] (let [out (f x)] (if (validator out) out x)))))
;;
;; sequential
;;
(defn -sequential->set [x]
(cond (set? x) x
(sequential? x) (set x)
:else x))
(defn -sequential->vector [x]
(cond (vector? x) x
(sequential? x) (vec x)
:else x))
;;
;; sequential or set
;;
(defn -sequential-or-set->vector [x]
(cond (vector? x) x
(set? x) (vec x)
(sequential? x) (vec x)
:else x))
(defn -sequential-or-set->seq [x]
(cond (vector? x) (seq x)
(set? x) (seq x)
:else x))
(defn -infer-child-compiler
[x-coders]
(fn [schema _]
(some-> schema
(m/children)
(m/-infer)
x-coders)))
(defn -add-child-compilers
[x-coders]
(assoc x-coders
:enum {:compile (-infer-child-compiler x-coders)}
:= {:compile (-infer-child-compiler x-coders)}))
;;
;; decoders
;;
(defn -base-json-decoders []
{'ident? -string->keyword
'simple-ident? -string->keyword
'qualified-ident? -string->keyword
'keyword? -string->keyword
'simple-keyword? -string->keyword
'qualified-keyword? -string->keyword
'symbol? -string->symbol
'simple-symbol? -string->symbol
'qualified-symbol? -string->symbol
'uuid? -string->uuid
'float? -number->float
'double? -number->double
'inst? -string->date
'integer? -number->long
'int? -number->long
'pos-int? -number->long
'neg-int? -number->long
'nat-int? -number->long
'zero? -number->long
#?@(:clj ['uri? -string->uri])
:float -number->float
:double -number->double
:int -number->long
:keyword -string->keyword
:symbol -string->symbol
:qualified-keyword -string->keyword
:qualified-symbol -string->symbol
:uuid -string->uuid
;#?@(:clj [:uri -string->uri])
:set -sequential->set})
(defn -json-decoders []
(-add-child-compilers
(-base-json-decoders)))
(defn -base-json-encoders []
{'keyword? m/-keyword->string
'simple-keyword? m/-keyword->string
'qualified-keyword? m/-keyword->string
'symbol? -any->string
'simple-symbol? -any->string
'qualified-symbol? -any->string
'uuid? -any->string
#?@(:clj ['uri? -any->string])
:keyword m/-keyword->string
:symbol -any->string
:qualified-keyword m/-keyword->string
:qualified-symbol -any->string
:uuid -any->string
;#?@(:clj [:uri -any->string])
;:bigdec any->string
'inst? -date->string
#?@(:clj ['ratio? -number->double])})
(defn -json-encoders []
(-add-child-compilers
(-base-json-encoders)))
(defn -string-decoders []
(-add-child-compilers
(merge
(-base-json-decoders)
{'integer? -string->long
'int? -string->long
'pos-int? -string->long
'neg-int? -string->long
'nat-int? -string->long
'zero? -string->long
:int -string->long
:float -string->float
:double -string->double
:boolean -string->boolean
:> -string->long
:>= -string->long
:< -string->long
:<= -string->long
:not= -string->long
'number? -string->double
'float? -string->float
'double? -string->double
#?@(:clj ['rational? -string->double])
#?@(:clj ['decimal? -string->decimal])
'boolean? -string->boolean
'false? -string->boolean
'true? -string->boolean
:map-of (-transform-map-keys m/-keyword->string)
:vector -sequential->vector})))
(defn -string-encoders []
(-add-child-compilers
(merge
(-base-json-encoders)
{'integer? -any->string
'int? -any->string
'pos-int? -any->string
'neg-int? -any->string
'nat-int? -any->string
'zero? -any->string
:int -any->string
:float -any->string
:double -any->string
;:boolean -any->string
:> -any->string
:>= -any->string
:< -any->string
:<= -any->string
:not= -any->string
'float -any->string
'double -any->string})))
;;
;; transformers
;;
(defn transformer [& ?transformers]
(let [->data (fn [ts default name key] {:transformers ts
:default default
:name name
:qname (when (and name (not (qualified-keyword? name)))
(keyword key (clojure.core/name name)))})
->eval (fn [x options] (if (map? x) (reduce-kv (fn [x k v] (assoc x k (m/eval v options))) x x) (m/eval x)))
->chain (m/-comp m/-transformer-chain m/-into-transformer)
chain (->> ?transformers (keep identity) (mapcat #(if (map? %) [%] (->chain %))) (vec))
chain' (->> chain (mapv #(let [name (:name %)]
{:decode (->data (:decoders %) (:default-decoder %) name "decode")
:encode (->data (:encoders %) (:default-encoder %) name "encode")})))]
(when (seq chain)
(reify
m/Transformer
(-transformer-chain [_] chain)
(-value-transformer [_ schema method options]
(reduce
(fn [acc {{:keys [name qname default transformers]} method}]
(let [options (or options (m/options schema))
from (fn [properties]
(or (when name
(some-> properties (get method) (get name) (->eval options)))
(when qname
(some-> properties (get qname) (->eval options)))))]
(if-let [?interceptor (or (from (m/properties schema))
(from (m/type-properties schema))
(get transformers (m/type schema))
default)]
(let [interceptor (-interceptor ?interceptor schema options)]
(if (nil? acc) interceptor (-interceptor [acc interceptor] schema options)))
acc))) nil chain'))))))
(defn json-transformer
([] (json-transformer nil))
([{::keys [json-vectors
keywordize-map-keys
map-of-key-decoders] :or {map-of-key-decoders (-string-decoders)}}]
(transformer
{:name :json
:decoders (-> (-json-decoders)
(assoc :map-of {:compile (fn [schema _]
(let [key-schema (some-> schema (m/children) (first))]
(or (some-> key-schema (m/type) map-of-key-decoders
(-interceptor schema {}) (m/-intercepting)
(m/-comp m/-keyword->string)
(-transform-if-valid key-schema)
(-transform-map-keys))
(-transform-map-keys m/-keyword->string))))})
(cond-> keywordize-map-keys
(assoc :map {:compile (fn [schema _]
(let [keyword-keys (->> (mu/keys schema)
(filter keyword?)
(map name)
set)]
(-transform-map-keys keyword-keys -string->keyword)))}))
(cond-> json-vectors (assoc :vector -sequential->vector)))
:encoders (-json-encoders)})))
(defn string-transformer []
(transformer
{:name :string
:decoders (-string-decoders)
:encoders (-string-encoders)}))
(defn strip-extra-keys-transformer
([] (strip-extra-keys-transformer nil))
([{:keys [accept] :or {accept (m/-comp #(or (nil? %) (true? %)) :closed m/properties)}}]
(let [strip-map {:compile (fn [schema _]
(let [default-schema (m/default-schema schema)
ks (some->> schema (m/explicit-keys) (set))]
(cond-> nil
(accept schema)
(assoc :enter (fn [x]
(if (and (map? x) (not default-schema))
(reduce-kv (fn [acc k _] (if-not (ks k) (dissoc acc k) acc)) x x)
x))))))}
strip-map-of (fn [stage]
{:compile (fn [schema options]
(let [entry-schema (m/into-schema :tuple nil (m/children schema) options)
valid? (m/validator entry-schema options)]
{stage (fn [x]
(reduce (fn [acc entry]
(if (valid? entry)
(apply assoc acc entry)
acc)) (empty x) x))}))})]
(transformer
{:decoders {:map strip-map, :map-of (strip-map-of :leave)}
:encoders {:map strip-map, :map-of (strip-map-of :enter)}}))))
(defn key-transformer [{:keys [decode encode types] :or {types #{:map}}}]
(let [transform (fn [f stage] (when f {stage (-transform-map-keys f)}))]
(transformer (cond (set? types) {:decoders (zipmap types (repeat (transform decode :enter)))
:encoders (zipmap types (repeat (transform encode :leave)))}
(= :default types) {:default-decoder (transform decode :enter)
:default-encoder (transform encode :leave)}))))
(defn default-value-transformer
([] (default-value-transformer nil))
([{:keys [key default-fn defaults ::add-optional-keys] :or {key :default, default-fn (fn [_ x] x)}}]
(let [get-default (fn [schema more-props]
(or (some-> schema m/properties :default/fn m/eval)
(some-> more-props :default/fn m/eval)
(if-some [e (or (some-> schema m/properties (find key))
(some-> more-props (find key)))]
(constantly (val e))
(some->> schema m/type (get defaults) (#(constantly (% schema)))))))
set-default {:compile (fn [schema _]
(when-some [f (get-default schema nil)]
(fn [x] (if (nil? x) (default-fn schema (f)) x))))}
add-defaults {:compile (fn [schema _]
(let [defaults (into {}
(keep (fn [[k {:keys [optional] :as p} v]]
(when (or (not optional) add-optional-keys)
(when-some [f (or (get-default v p)
(when (m/-ref-schema? v)
(get-default (m/-deref v) p)))]
[k (fn [] (default-fn schema (f)))]))))
(m/children schema))]
(when (seq defaults)
(fn [x]
(if (map? x)
(reduce-kv
(fn [acc k f]
(if-not (contains? x k)
(assoc acc k (f))
acc))
x defaults)
x)))))}]
(transformer
{:default-decoder set-default
:default-encoder set-default}
{:decoders {:map add-defaults}
:encoders {:map add-defaults}}))))
(defn collection-transformer []
(let [coders {:vector -sequential-or-set->vector
:sequential -sequential-or-set->seq
:set -sequential->set
:tuple -sequential->vector}]
(transformer
{:decoders coders
:encoders coders})))
malli/src/malli/util.cljc
Vendored
+404
View File
@@ -0,0 +1,404 @@
(ns malli.util
(:refer-clojure :exclude [merge select-keys find get get-in dissoc assoc update assoc-in update-in keys])
(:require [clojure.core :as c]
[malli.core :as m]))
(declare path->in find)
(defn ^:no-doc equals
([?schema1 ?schema2]
(equals ?schema1 ?schema2 nil))
([?schema1 ?schema2 options]
(= (m/form ?schema1 options) (m/form ?schema2 options))))
(defn -simplify-map-entry [[k ?p s]]
(cond
(not s) [k ?p]
(and ?p (false? (:optional ?p)) (= 1 (count ?p))) [k s]
(not (seq ?p)) [k s]
(false? (:optional ?p)) [k (c/dissoc ?p :optional) s]
:else [k ?p s]))
(defn -required-map-entry? [[_ ?p]]
(not (and (map? ?p) (true? (:optional ?p)))))
(defn- -entry [[k ?p1 s1 :as e1] [_ ?p2 s2 :as e2] merge-required merge options]
(let [required (merge-required (-required-map-entry? e1) (-required-map-entry? e2))
p (c/merge ?p1 ?p2)]
(-simplify-map-entry [k (c/assoc p :optional (not required)) (merge s1 s2 options)])))
(defn- -ok-to-close-or-open? [schema options]
(and (= :map (m/type schema options)) (-> schema m/properties :closed false? not)))
;;
;; public api
;;
(defn find-first
"Prewalks the Schema recursively with a 3-arity fn [schema path options], returns with
and as soon as the function returns non-null value."
([?schema f]
(find-first ?schema f nil))
([?schema f options]
(let [result (atom nil)]
(m/-walk
(m/schema ?schema options)
(reify m/Walker
(-accept [_ s path options] (not (or @result (reset! result (f s path options)))))
(-inner [this s path options] (when-not @result (m/-walk s this path options)))
(-outer [_ _ _ _ _]))
[] options)
@result)))
(defn merge
"Merges two schemas into one with the following rules:
* if either schemas is `nil`, the other one is used, regardless of value
* with two :map schemas, both keys and values are merged
* for :and schemas, the first child is used in merge, rest kept as-is
* with two :map entries, `:merge-entries` fn is used (default last one wins)
* with any other schemas, `:merge-default` fn is used (default last one wins)
| key | description
| ------------------|-------------
| `:merge-default` | `schema1 schema2 options -> schema` fn to merge unknown entries
| `:merge-required` | `boolean boolean -> boolean` fn to resolve how required keys are merged"
([?schema1 ?schema2]
(merge ?schema1 ?schema2 nil))
([?schema1 ?schema2 options]
(let [s1 (when ?schema1 (m/deref-all (m/schema ?schema1 options)))
s2 (when ?schema2 (m/deref-all (m/schema ?schema2 options)))
t1 (when s1 (m/type s1))
t2 (when s2 (m/type s2))
can-distribute? (and (not (contains? options :merge-default))
(not (contains? options :merge-required)))
{:keys [merge-default merge-required]
:or {merge-default (fn [_ s2 _] s2)
merge-required (fn [_ r2] r2)}} options
bear (fn [p1 p2] (if (and p1 p2) (c/merge p1 p2) (or p1 p2)))
tear (fn [t s] (if (= :map t) [nil s] (concat [(m/properties s)] (m/children s))))
join (fn [[p1 c1 & cs1] [p2 c2 & cs2]]
(m/into-schema :and (bear p1 p2) (concat [(merge c1 c2 options)] cs1 cs2) options))]
(cond
(nil? s1) s2
(nil? s2) s1
;; right-distributive: [:merge [:multi M1 M2 ...] M3] => [:multi [:merge M1 M3] [:merge M2 M3] ...]
(and can-distribute? (m/-distributive-schema? s1)) (m/-distribute-to-children s1 (fn [s _options] (merge s s2 options)) options)
;; left-distributive: [:merge M1 [:multi M2 M3 ...]] => [:multi [:merge M1 M2] [:merge M1 M3] ...]
(and can-distribute? (m/-distributive-schema? s2)) (m/-distribute-to-children s2 (fn [s _options] (merge s1 s options)) options)
(not (and (-> t1 #{:map :and}) (-> t2 #{:map :and}))) (merge-default s1 s2 options)
(not (and (-> t1 (= :map)) (-> t2 (= :map)))) (join (tear t1 s1) (tear t2 s2))
:else (let [p (bear (m/-properties s1) (m/-properties s2))
ks (atom #{})
children (reduce (fn [form [k2 :as e2]]
(if (@ks k2)
(reduce (fn [acc' [k1 :as e1]]
(conj acc' (if (= k1 k2)
(-entry e1 e2 merge-required merge options)
e1))) [] form)
(do (swap! ks conj k2) (conj form e2))))
[] (into (m/-children s1) (m/-children s2)))]
(m/into-schema :map p children options))))))
(defn union
"Union of two schemas. See [[merge]] for more details."
([?schema1 ?schema2]
(union ?schema1 ?schema2 nil))
([?schema1 ?schema2 options]
(let [merge-default (fn [s1 s2 options] (if (equals s1 s2) s1 (m/schema [:or s1 s2] options)))
merge-required (fn [r1 r2] (and r1 r2))]
(merge ?schema1 ?schema2 (-> options
(c/update :merge-default (fnil identity merge-default))
(c/update :merge-required (fnil identity merge-required)))))))
(defn update-properties
"Returns a Schema instance with updated properties."
[?schema f & args]
(let [schema (m/schema ?schema)]
(apply m/-update-properties schema f args)))
(defn update-entry-properties
"Returns a Schema instance with updated properties for entry k."
[?schema k f & args]
(let [schema (m/schema ?schema)
[k p v] (or (find schema k)
(m/-fail! ::no-entry {:schema schema :k k}))]
(m/-set-entries schema [k (apply f p args)] v)))
(defn closed-schema
"Maps are implicitly open by default. They can be explicitly closed or
open by specifying the `{:closed (true|false)}` property.
This function converts implicitly open maps to explicitly closed
maps, recursively. Explicitly open maps are left untouched.
See [[open-schema]]"
([?schema]
(closed-schema ?schema nil))
([?schema options]
(m/walk
?schema
(m/schema-walker
(fn [schema]
(if (-ok-to-close-or-open? schema options)
(update-properties schema c/assoc :closed true)
schema)))
options)))
(defn open-schema
"Maps are implicitly open by default. They can be explicitly closed or
open by specifying the `{:closed (true|false)}` property.
This function converts explicitly closed maps to implicitly open
maps, recursively. Explicitly open maps are left untouched.
See [[closed-schema]]"
([?schema]
(open-schema ?schema nil))
([?schema options]
(m/walk
?schema
(m/schema-walker
(fn [schema]
(if (-ok-to-close-or-open? schema options)
(update-properties schema c/dissoc :closed)
schema)))
options)))
(defn subschemas
"Returns all subschemas for unique paths as a vector of maps with :schema, :path and :in keys.
Walks over :schema references and top-level :refs. See [[malli.core/-walk]] for all options."
([?schema]
(subschemas ?schema nil))
([?schema options]
(let [schema (m/schema ?schema options)
options (let [ref (and (= :ref (m/type schema)) (m/-ref schema))]
(-> options
(clojure.core/update ::m/walk-schema-refs (fnil identity true))
(clojure.core/update ::m/walk-refs (fn [f] #(or (= ref %) ((m/-boolean-fn f) %))))))
state (atom [])]
(find-first schema (fn [s p _] (swap! state conj {:path p, :in (path->in schema p), :schema s}) nil) options)
@state)))
(defn distinct-by
"Returns a sequence of distinct (f x) values)"
[f coll]
(let [seen (atom #{})]
(filter (fn [x] (let [v (f x)] (when-not (@seen v) (swap! seen conj v)))) coll)))
(defn path->in
"Returns a value path for a given Schema and schema path"
[schema path]
(loop [i 0, s schema, acc []]
(or (and (>= i (count path)) acc)
(recur (inc i) (m/-get s (path i) nil) (cond-> acc (m/-keep s) (conj (path i)))))))
(defn in->paths
"Returns a vector of schema paths for a given Schema and value path"
[schema in]
(let [state (atom [])
in-equals (fn [[x & xs] [y & ys]] (cond (and x (= x y)) (recur xs ys), (= x y) true, (= ::m/in x) (recur xs ys)))
parent-exists (fn [v1 v2] (let [i (min (count v1) (count v2))] (= (subvec v1 0 i) (subvec v2 0 i))))]
(find-first
schema
(fn [_ path _]
(when (and (in-equals (path->in schema path) in) (not (some #(parent-exists path %) @state)))
(swap! state conj path) nil)))
@state))
(defn data-explainer
"Like `m/explainer` but output is pure clojure data. Schema objects have been replaced with their m/form.
Useful when you need to serialise errrors."
([?schema]
(data-explainer ?schema nil))
([?schema options]
(let [explainer' (m/explainer ?schema options)]
(fn data-explainer
([value]
(data-explainer value [] []))
([value in acc]
(some-> (explainer' value in acc)
(c/update :schema m/form)
(c/update :errors (partial mapv #(c/update % :schema m/form)))))))))
(defn explain-data
"Explains a value against a given schema. Like `m/explain` but output is pure clojure data.
Schema objects have been replaced with their `m/form`. Useful when you need to serialise errrors.
Creates the `mu/data-explainer` for every call. When performance matters, (re-)use `mu/data-explainer` instead."
([?schema value]
(explain-data ?schema value nil))
([?schema value options]
((data-explainer ?schema options) value [] [])))
;;
;; EntrySchemas
;;
(defn transform-entries
"Transforms entries with f."
([?schema f]
(transform-entries ?schema f nil))
([?schema f options]
(let [schema (m/deref-all (m/schema ?schema options))]
(m/into-schema (m/-parent schema) (m/-properties schema) (f (m/-children schema)) (or (m/options schema) options)))))
(defn optional-keys
"Makes map keys optional."
([?schema]
(optional-keys ?schema nil nil))
([?schema ?keys]
(let [[keys options] (if (map? ?keys) [nil ?keys] [?keys nil])]
(optional-keys ?schema keys options)))
([?schema keys options]
(let [accept (if keys (set keys) (constantly true))
mapper (fn [[k :as e]] (if (accept k) (c/update e 1 c/assoc :optional true) e))]
(transform-entries ?schema #(map mapper %) options))))
(defn required-keys
"Makes map keys required."
([?schema]
(required-keys ?schema nil nil))
([?schema ?keys]
(let [[keys options] (if (map? ?keys) [nil ?keys] [?keys nil])]
(required-keys ?schema keys options)))
([?schema keys options]
(let [accept (if keys (set keys) (constantly true))
required (fn [p] (let [p' (c/dissoc p :optional)] (when (seq p') p')))
mapper (fn [[k :as e]] (if (accept k) (c/update e 1 required) e))]
(transform-entries ?schema #(map mapper %) options))))
(defn select-keys
"Like [[clojure.core/select-keys]], but for EntrySchemas."
([?schema keys]
(select-keys ?schema keys nil))
([?schema keys options]
(let [key-set (set keys)]
(transform-entries ?schema #(filter (fn [[k]] (key-set k)) %) options))))
(defn rename-keys
"Like [[clojure.set/rename-keys]], but for EntrySchemas. Collisions are resolved in favor of the renamed key, like `assoc`-ing."
([?schema kmap]
(rename-keys ?schema kmap nil))
([?schema kmap options]
(transform-entries
?schema
(fn [entries]
(let [source-keys (set (c/keys kmap))
target-keys (set (vals kmap))
remove-conflicts (fn [[k]] (or (source-keys k) (not (target-keys k))))
alter-keys (fn [[k m v]] [(c/get kmap k k) m v])]
(->> entries (filter remove-conflicts) (map alter-keys))))
options)))
(defn dissoc
"Like [[clojure.core/dissoc]], but for EntrySchemas. Only supports one key at a time."
([?schema key]
(dissoc ?schema key nil))
([?schema key options]
(transform-entries ?schema #(remove (fn [[k]] (= key k)) %) options)))
(defn find
"Like [[clojure.core/find]], but for EntrySchemas."
([?schema k]
(find ?schema k nil))
([?schema k options]
(let [schema (m/schema (or ?schema :map) options)]
(when schema (m/-get schema [::m/find k] nil)))))
(defn keys
"Like [[clojure.core/keys]], but for EntrySchemas."
[?schema]
(when-let [ents (m/entries ?schema)]
(for [[k _] ents]
k)))
;;
;; LensSchemas
;;
(defn get
"Like [[clojure.core/get]], but for LensSchemas."
([?schema k]
(get ?schema k nil nil))
([?schema k default]
(get ?schema k default nil))
([?schema k default options]
(let [schema (m/schema (or ?schema :map) options)]
(when schema (m/-get schema k default)))))
(defn assoc
"Like [[clojure.core/assoc]], but for LensSchemas. Only supports one key-value pair at a time."
([?schema key value]
(assoc ?schema key value nil))
([?schema key value options]
(m/-set (m/schema ?schema options) key value)))
(defn update
"Like [[clojure.core/update]], but for LensSchema instances."
[schema key f & args]
(m/-set (m/schema schema) key (apply f (get schema key) args)))
(defn get-in
"Like [[clojure.core/get-in]], but for LensSchemas."
([?schema ks]
(get-in ?schema ks nil nil))
([?schema ks default]
(get-in ?schema ks default nil))
([?schema ks default options]
(let [schema (m/schema (or ?schema :map) options)]
(if-not (seq ks)
schema
(let [[k & ks] ks
sentinel #?(:clj (Object.), :cljs (js-obj))
schema (get schema k sentinel)]
(cond
(identical? schema sentinel) default
ks (get-in schema ks default)
:else schema))))))
(defn assoc-in
"Like [[clojure.core/assoc-in]], but for LensSchemas."
([?schema ks value]
(assoc-in ?schema ks value nil))
([?schema [k & ks] value options]
(let [schema (m/schema ?schema options)]
(assoc schema k (if ks (assoc-in (get schema k (m/schema :map (m/options schema))) ks value) value)))))
(defn update-in
"Like [[clojure.core/update-in]], but for LensSchemas."
[schema ks f & args]
(letfn [(up [s [k & ks] f args]
(assoc s k (if ks (up (get s k (m/schema :map (m/options schema))) ks f args)
(apply f (get s k) args))))]
(up schema ks f args)))
;;
;; Schemas
;;
(defn -reducing [f]
(fn [_ children options]
(when (empty? children)
(m/-fail! ::reducing-children-must-be-non-empty))
(let [[first & rest :as children] (mapv #(m/schema % options) children)]
[children (mapv m/form children) (delay (reduce #(f %1 %2 options) first rest))])))
(defn -applying [f]
(fn [_ children options]
(let [children (clojure.core/update children 0 m/schema options)]
[children
(clojure.core/update children 0 m/-form)
(delay (if (= 2 (count children))
(f (nth children 0) (nth children 1) options)
(apply f (conj children options))))])))
(defn -util-schema [m] (m/-proxy-schema m))
(defn -merge [] (-util-schema {:type :merge, :fn (-reducing merge), :min 1}))
(defn -union [] (-util-schema {:type :union, :fn (-reducing union), :min 1}))
(defn -select-keys [] (-util-schema {:type :select-keys, :childs 1, :min 2, :max 2, :fn (-applying select-keys)}))
(defn schemas [] {:merge (-merge)
:union (-union)
:select-keys (-select-keys)})
malli/test-cherry/malli/load_test.cljs
Vendored
+5
View File
@@ -0,0 +1,5 @@
(ns malli.load-test
(:require [malli.cherry]))
(println "Cherry integration loaded for tests")
malli/test-doc-tests.edn
Vendored
+8
View File
@@ -0,0 +1,8 @@
;; Needed to run tests generated with test-doc-blocks. For them to work we need :randomize? false, which
;; is not what we want for the majority of the test cases.
#kaocha/v1
{:tests [{:id :generated
:test-paths ["target/test-doc-blocks/test"]
:kaocha.hooks/post-load-test [lread.test-doc-blocks.kaocha.hooks/fail-on-no-tests-found]}]
:reporter kaocha.report/documentation
:randomize? false}
malli/test-sci/malli/load_test.cljs
Vendored
+4
View File
@@ -0,0 +1,4 @@
(ns malli.load-test
(:require [sci.core]))
(println "SCI loaded for tests")
malli/test/bb_test_runner.clj
Vendored
+42
View File
@@ -0,0 +1,42 @@
(ns bb-test-runner
(:require
[clojure.test :as t]
[malli.clj-kondo-test]
[malli.core-test]
[malli.destructure-test]
[malli.dot-test]
[malli.error-test]
[malli.experimental-test]
[malli.generator-test]
[malli.instrument-test]
[malli.json-schema-test]
[malli.parser-test]
[malli.plantuml-test]
[malli.provider-test]
[malli.registry-test]
[malli.swagger-test]
[malli.transform-test]
[malli.util-test]))
(defn run-tests [& _args]
(let [{:keys [fail error]}
(t/run-tests
'malli.core-test
'malli.clj-kondo-test
'malli.destructure-test
'malli.dot-test
'malli.error-test
'malli.experimental-test
'malli.instrument-test
'malli.json-schema-test
;; 'malli.generator-test ;; skipped for now due to test.chuck incompatibility
'malli.parser-test
'malli.plantuml-test
'malli.provider-test
'malli.registry-test
'malli.swagger-test
'malli.transform-test
'malli.util-test)]
(when (or (pos? fail)
(pos? error))
(System/exit 1))))
malli/test/demo.clj
Vendored
+36
View File
@@ -0,0 +1,36 @@
(ns demo)
(require '[malli.dev.pretty :as pretty])
(def Adult
[:map
[:age [:int {:min 18}]]
[:home [:map
[:city :string]
[:zip :int]]]])
(comment
(pretty/explain
Adult
{:name "Endy"
:age 17
:home {:zip 33100}}))
(comment
(pretty/explain
[:map
[:id :int]
[:tags [:set :keyword]]
[:address [:map
[:street :string]
[:city :string]
[:zip :int]
[:lonlat [:tuple :double :double]]]]]
{:id "123"
:EXTRA "KEY"
:tags #{:artesan "coffee" :garden}
:address {:street "Ahlmanintie 29"
:city "Tampere"
:zip 33100
:lonlat [61.4858322, 23.7832851]}}))
malli/test/malli/assert_test.cljc
Vendored
+29
View File
@@ -0,0 +1,29 @@
(ns malli.assert-test
(:refer-clojure :exclude [assert])
(:require
[clojure.test :refer [deftest is]]
[malli.core :refer [assert]]))
(set! *assert* true)
(deftest assert-throws-test
(is (thrown? #?(:clj Exception, :cljs js/Error)
(assert :int "42" )))
(is (thrown? #?(:clj Exception, :cljs js/Error)
(assert int? "42" )))
(is (thrown? #?(:clj Exception, :cljs js/Error)
(assert string? 42)))
(is (thrown? #?(:clj Exception, :cljs js/Error)
(assert int? nil)))
(is (thrown? #?(:clj Exception, :cljs js/Error)
(assert [:map [:a int?]] {:a "42"})))
(is (thrown? #?(:clj Exception, :cljs js/Error)
(assert ::invalid-schema 42))))
(deftest assert-checked-and-does-not-throw
(is (= 42 (assert :int 42 )))
(is (= 42 (assert int? 42 )))
(is (= "42" (assert string? "42")))
(is (= nil (assert any? nil)))
(is (= {:a 42} (assert [:map [:a int?]] {:a 42}))))

Some files were not shown because too many files have changed in this diff Show More