/
utils.cljc
178 lines (139 loc) · 5.93 KB
/
utils.cljc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
(ns schema.utils
"Private utilities used in schema implementation."
(:refer-clojure :exclude [record?])
#?(:clj (:require [clojure.string :as string])
:cljs (:require
goog.string.format
[goog.object :as gobject]
[goog.string :as gstring]
[clojure.string :as string]))
#?(:cljs (:require-macros [schema.utils :refer [char-map]])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Miscellaneous helpers
(defn assoc-when
"Like assoc but only assocs when value is truthy. Copied from plumbing.core so that
schema need not depend on plumbing."
[m & kvs]
(assert (even? (count kvs)))
(into (or m {})
(for [[k v] (partition 2 kvs)
:when v]
[k v])))
(defn type-of [x]
#?(:clj (class x)
:cljs (js* "typeof ~{}" x)))
(defn fn-schema-bearer
"What class can we associate the fn schema with? In Clojure use the class of the fn; in
cljs just use the fn itself."
[f]
#?(:clj (class f)
:cljs f))
(defn format* [fmt & args]
(apply #?(:clj format :cljs gstring/format) fmt args))
(def max-value-length (atom 19))
(defn value-name
"Provide a descriptive short name for a value."
[value]
(let [t (type-of value)]
(if (<= (count (str value)) @max-value-length)
value
(symbol (str "a-" #?(:clj (.getName ^Class t) :cljs t))))))
#?(:clj
(defmacro char-map []
clojure.lang.Compiler/CHAR_MAP))
#?(:clj
(defn unmunge
"TODO: eventually use built in demunge in latest cljs."
[s]
(->> (char-map)
(sort-by #(- (count (second %))))
(reduce (fn [^String s [to from]] (string/replace s from (str to))) s))))
(defn fn-name
"A meaningful name for a function that looks like its symbol, if applicable."
[f]
#?(:cljs
(let [[_ s] (re-matches #"#object\[(.*)\]" (pr-str f))]
(if (= "Function" s)
"function"
(->> s demunge (re-find #"[^/]+(?:$|(?=/+$))"))))
:clj (let [s (.getName (class f))
slash (.lastIndexOf s "$")
raw (unmunge
(if (>= slash 0)
(str (subs s 0 slash) "/" (subs s (inc slash)))
s))]
(string/replace raw #"^clojure.core/" ""))))
(defn record? [x]
#?(:clj (instance? clojure.lang.IRecord x)
:cljs (satisfies? IRecord x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Error descriptions
;; A leaf schema validation error, describing the schema and value and why it failed to
;; match the schema. In Clojure, prints like a form describing the failure that would
;; return true.
(declare validation-error-explain)
(deftype ValidationError [schema value expectation-delay fail-explanation]
#?(:cljs IPrintWithWriter)
#?(:cljs (-pr-writer [this writer opts]
(-pr-writer (validation-error-explain this) writer opts))))
(defn validation-error-explain [^ValidationError err]
(list (or (.-fail-explanation err) 'not) @(.-expectation-delay err)))
#?(:clj ;; Validation errors print like forms that would return false
(defmethod print-method ValidationError [err writer]
(print-method (validation-error-explain err) writer)))
(defn make-ValidationError
"for cljs sake (easier than normalizing imports in macros.clj)"
[schema value expectation-delay fail-explanation]
(ValidationError. schema value expectation-delay fail-explanation))
;; Attach a name to an error from a named schema.
(declare named-error-explain)
(deftype NamedError [name error]
#?(:cljs IPrintWithWriter)
#?(:cljs (-pr-writer [this writer opts]
(-pr-writer (named-error-explain this) writer opts))))
(defn named-error-explain [^NamedError err]
(list 'named (.-error err) (.-name err)))
#?(:clj ;; Validation errors print like forms that would return false
(defmethod print-method NamedError [err writer]
(print-method (named-error-explain err) writer)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Monoidish error containers, which wrap errors (to distinguish from success values).
(defrecord ErrorContainer [error])
(defn error
"Distinguish a value (must be non-nil) as an error."
[x] (assert x) (->ErrorContainer x))
(defn error? [x]
(instance? ErrorContainer x))
(defn error-val [x]
(when (error? x)
(.-error ^ErrorContainer x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Registry for attaching schemas to classes, used for defn and defrecord
#?(:clj
(let [^java.util.Map +class-schemata+ (java.util.Collections/synchronizedMap (java.util.WeakHashMap.))]
(defn declare-class-schema! [klass schema]
"Globally set the schema for a class (above and beyond a simple instance? check).
Use with care, i.e., only on classes that you control. Also note that this
schema only applies to instances of the concrete type passed, i.e.,
(= (class x) klass), not (instance? klass x)."
(assert (class? klass)
(format* "Cannot declare class schema for non-class %s" (class klass)))
(.put +class-schemata+ klass schema))
(defn class-schema [klass]
"The last schema for a class set by declare-class-schema!, or nil."
(.get +class-schemata+ klass))))
#?(:cljs
(do
(defn declare-class-schema! [klass schema]
(gobject/set klass "schema$utils$schema" schema))
(defn class-schema [klass]
(gobject/get klass "schema$utils$schema"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Utilities for fast-as-possible reference to use to turn fn schema validation on/off
(def use-fn-validation
"Turn on run-time function validation for functions compiled when
s/compile-fn-validation was true -- has no effect for functions compiled
when it is false."
;; specialize in Clojure for performance
#?(:clj (java.util.concurrent.atomic.AtomicReference. false)
:cljs (atom false)))