-
Notifications
You must be signed in to change notification settings - Fork 4
/
lens.cljc
403 lines (346 loc) · 12.4 KB
/
lens.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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
(ns active.clojure.lens
"Lenses should obey the following laws:
GetPut, or YankShove:
(= (yank (shove data my-lens val)
my-lens)
val)
Meaning: you get back what you put in.
PutGet, or ShoveYank:
(= (shove data
my-lens
(yank data my-lens))
data)
Meaning: putting back what you got does not change anything.
PutPut, or ShoveShove:
(= (shove data my-lens val-1)
(shove (shove data my-lens val-2) my-lens val-1))
Meaning: second shove wins, or shoving once is the same as shoving twice.
A lens that satisfies these three laws is usually called \"very well-behaved\".
See also `active.clojure.lens-test/lens-laws-hold`."
(:require [active.clojure.functions :as f]
[clojure.set :as set])
(:refer-clojure :exclude [merge first second]))
(defn yank
"Yank a value from the given data value, as defined by the given
lens."
[data lens]
(lens data))
(defn shove
"Shove a new value v into the given data value, as defined by the
given lens, and return the updated data structure."
[data lens v]
(if (keyword? lens)
(assoc data lens v)
(lens data v)))
(defn- throw-invalid-number-of-arguments-error [n]
(let [error-msg (str "invalid number of arguments (" n ") to lens")]
(throw (java.lang.IllegalArgumentException. error-msg))))
(defrecord ExplicitLens
^{:private true}
[yanker shover args]
#?@(:clj [clojure.lang.IFn
(invoke [this data] (apply yanker data args))
(invoke [this data v] (apply shover data v args))
(applyTo [this apply-args]
(let [apply-args (object-array apply-args)]
(case (count apply-args)
1 (apply yanker (aget apply-args 0) args)
2 (apply shover (aget apply-args 0) (aget apply-args 1) args)
(throw-invalid-number-of-arguments-error (count apply-args)))))]
:cljs [IFn
(-invoke [this data] (apply yanker data args))
(-invoke [this data v] (apply shover data v args))]))
(defrecord ExplicitLensWithoutArgs
^{:private true}
[yanker shover]
#?@(:clj [clojure.lang.IFn
(invoke [this data] (yanker data))
(invoke [this data v] (shover data v))
(applyTo [this apply-args]
(let [apply-args (object-array apply-args)]
(case (count apply-args)
1 (yanker (aget apply-args 0))
2 (shover (aget apply-args 0) (aget apply-args 1))
(throw-invalid-number-of-arguments-error (count apply-args)))))]
:cljs [IFn
(-invoke [this data] (yanker data))
(-invoke [this data v] (shover data v))]))
(defn lens
"Returns a new lens defined by the given yanker function, which
takes a data structure and must return the focused value, and the
given shover function which takes a data structure and the new value
in the focus. Any additional arguments are passed unchanged to the yank
and shove functions."
([yanker shover]
(ExplicitLensWithoutArgs. yanker shover))
([yanker shover & args]
(ExplicitLens. yanker shover args)))
(defn- xmap-yank [data f g & args]
(apply f data args))
(defn- xmap-shove [data v f g & args]
(apply g v args))
(defn overhaul
"Updates data using a lens. The new value will be determined by
applying `f` to the old value and any other supplied arguments."
([data lens f]
(shove data lens (f (yank data lens))))
([data lens f & args]
(shove data lens (apply f (yank data lens) args))))
(defn xmap
"Returns a \"view lens\", that transforms a whole data structure
to something else (f) and back (g)."
[f g & args]
(apply lens xmap-yank xmap-shove f g args))
(def
^{:doc "Identity lens, that just show a data structure as it is.
It's also the neutral element of lens concatenation
`reacl.lens/>>`."}
id (xmap identity identity))
(defn- keyword-shove [data val key]
(assoc data key val))
(defn- keyword-lens [kw]
(lens get
keyword-shove
kw))
(defn- lift-lens [my-lens]
(if (keyword? my-lens)
(keyword-lens my-lens)
my-lens))
(defn- comb-yank [data lenses]
(reduce (fn [data my-lens]
(my-lens data))
data
lenses))
(defn- comb-shove [data val lenses]
(let [lens-1 (clojure.core/first lenses)
remaining (rest lenses)]
(if (empty? remaining)
(lens-1 data val)
(lens-1 data
(comb-shove (lens-1 data)
val
remaining)))))
(defn >>
"Returns a concatenation of lenses, so that the combination shows the
value of the last one, in a data structure that the first one is put
over."
[& lenses]
(let [non-trivial-lenses (remove #{id} lenses)]
(if (empty? (rest non-trivial-lenses))
(or (clojure.core/first non-trivial-lenses)
id)
(lens comb-yank comb-shove (mapv lift-lens non-trivial-lenses)))))
(defn- default-yank [data dflt]
(if (nil? data) dflt data))
(defn- default-shove [v dflt]
(if (= dflt v) nil v))
(defn default
"Returns a lens that shows nil as the given default value, but does not change any other value."
[dflt]
(xmap default-yank default-shove dflt))
(defn- consx [v coll]
(if (and (nil? v) (empty? coll))
coll
(cons v coll)))
(def
^{:doc "A lens focusing on the first element in a collection. It
yanks nil if the collection is empty, and will not insert nil into an empty collection."}
head
(lens clojure.core/first
#(consx %2 (rest %1))))
(def
^{:doc "A lens focusing on the first element in a non-empty
collection. Behaviour on an empty collection is undefined."}
nel-head
(lens clojure.core/first
#(cons %2 (rest %1))))
(def
^{:doc "A lens focusing on the all but the first element in a collection.
Note that nil will be prepended when shoving into an empty collection."}
tail
(lens rest
#(consx (clojure.core/first %1) %2)))
(def
^{:doc "A lens focusing on the all but the first element in a non-empty collection.
Behaviour on an empty collection is undefined."}
nel-tail
(lens rest
#(cons (clojure.core/first %1) %2)))
(let [pos-get (fn [data n]
(clojure.core/first (drop n data)))
pos-set (fn [data v n]
(let [[front back] (split-at n data)
ff (take n front)]
(concat ff (repeat (- n (count ff)) nil) (list v) (rest back))))]
(defn pos
"A lens over the nth element in a sequence. Note that when shoving a
new value `nil`s may be added before the given position, if the collection is smaller."
[n]
(assert (number? n))
(assert (>= n 0))
(lens pos-get
pos-set
n)))
(def ^{:doc "A lens that views a sequence as a set."}
as-set
(lens set
; this is needed to abide the second lens law
#(if (= (set %1) %2)
%1
(seq %2))))
(defn- contains-shove [data mem? v]
(if mem?
(conj data v)
(disj data v)))
(defn contains
"Returns a lens showing the membership of the given value in a set."
[v]
(lens contains?
contains-shove
v))
(def ^{:doc "A lens that views a sequence of pairs as a map."}
as-map
(xmap #(into {} %) seq))
(defn- member-shove [data v key not-found]
(if (= v not-found)
(dissoc data key)
(assoc data key v)))
(defn member
"Returns a lens showing the value mapped to the given key in a map,
not-found or nil if key is not present. Note that when not-found (or
nil) is shoved into the map, the association is removed."
[key & [not-found]]
(lens get
member-shove
key
not-found))
(def ^{:doc "A trivial lens that just shows nil over anything, and does never change anything."}
void
(lens (constantly nil) (fn [data _] data)))
(defn- is-shove [data is? cmp]
(if is?
cmp
(if (= data cmp)
nil
data)))
(defn is
"Returns a lens showing if a data structure equals the non-nil value v."
[v]
(assert (not (nil? v)))
(lens =
is-shove
v))
(defn- mult-yank [data lenses]
(map yank
data lenses))
(defn- mult-shove [data v lenses]
(map shove
data lenses v))
(defn **
"Return the product of several lenses, which means that each lens is
held over an element of a collection in the order they appear in the
argument list."
[& lenses]
(lens mult-yank
mult-shove
lenses))
(defn- plus-yank [data lenses]
(map yank
(repeat data)
lenses))
(defn- plus-shove [data v lenses]
(reduce (fn [data [l v]] (shove data l v))
data
(map vector lenses v)))
(defn ++
"Returns a lens over some data structure that shows a sequence of
elements that each of the given lenses show on that. Note that the
behaviour is undefined if those lenses do not show distrinct parts
of the data structure."
[& lenses]
(lens plus-yank
plus-shove
lenses))
(defn- at-index-shove [coll v n]
(let [[front back] (split-at n coll)]
(let [s (concat front
(list v)
(rest back))]
(if (list? coll)
(apply list s)
(if (seq? coll)
s
(into (empty coll) s))))))
(defn at-index
"Returns a lens that focuses on the value at index n in a collection.
The sequence must have >= n elements. Preserves the collection type when shoving."
[n]
(lens nth
at-index-shove
n))
(def ^{:doc "A lens over the first element in a collection. Equivent to [[at-index]] of 0."}
first
(at-index 0))
(def ^{:doc "A lens over the second element in a collection. Equivent to [[at-index]] of 1."}
second
(at-index 1))
(letfn [(shove-1 [struct ns keep]
(let [skeys (keys struct)]
[(reduce (fn [res k]
(if (contains? ns k)
(assoc res k (get ns k))
(if (contains? keep k)
res
(dissoc res k))))
struct
skeys)
(select-keys ns (set/difference (set (keys ns)) (set skeys)))]))]
(def ^{:doc "A lens over a sequence of maps or records, that yields
a merged map of all of them. If maps or records have fields of the
same name, the value in right most map is used and updated on a
change. If an update contains new keys, they are put in the left-most
map. If an update misses keys, those fields are removed on the
right-most element where they were before."} merge
(fn
([structs]
(apply clojure.core/merge structs))
([structs ns]
(if (empty? structs)
structs ;; or maybe that should be an error?
(let [[result remain keep] (reduce (fn [[result remain keep] next-struct]
(let [[next-res next-remain] (shove-1 next-struct remain keep)]
[(cons next-res result)
next-remain
;; structs to the left can keep the keys that were 'shadowed' by this.
(set/union keep (set (keys next-struct)))
]))
[nil ns #{}]
(reverse structs))]
(->> (cons (clojure.core/merge (clojure.core/first result) remain)
(rest result))
(into (empty structs)))))))))
(let [map-f (fn
([mp outer]
(reduce-kv (fn [inner k lens]
(assoc inner k (yank outer lens)))
mp mp))
([mp outer inner]
(reduce-kv (fn [outer k lens]
(shove outer lens (get inner k)))
outer
mp)))
vec-f (fn
([v outer]
(mapv (fn [lens]
(yank outer lens))
v))
([v outer inner]
(reduce (fn [outer i]
(shove outer (get v i) (get inner i)))
outer
(range (count v)))))]
(defn pattern [p]
(cond
(map? p) (f/partial map-f p)
(vector? p) (f/partial vec-f p)
:else (assert false "Pattern must be a map or a vector."))))