blob: 6e8b583158c9d249b6fe947df579099cf92d5981 (
plain)
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
|
(define-module (test hnh-util-lens)
:use-module (srfi srfi-64)
:use-module (srfi srfi-64 test-error)
:use-module (srfi srfi-88)
:use-module ((hnh util) :select (enumerate))
:use-module (hnh util lens))
(define first (ref 0))
(test-equal '((1)) (get '(((1))) first))
(test-equal '((2)) (set '(((1))) (compose-lens first first) 2))
(test-equal '(((2))) (set '(((1))) (compose-lens first first first) 2))
;; (list-change (iota 10) 5 'Hello)
;; => (0 1 2 3 4 Hello 6 7 8 9)
(test-equal '(1 (10) 3) (set '(1 (2) 3)
(compose-lens (ref 1) (ref 0))
10))
(test-equal '(1 (10) 3) (set '(1 (2) 3)
(compose-lens (ref 1) (ref 0))
10))
;; (set (list (iota 10)) first first 11)
(define cadr* (compose-lens cdr* car*))
(test-group "Primitive lenses get and set"
(define lst '(1 2 3 4 5))
(test-equal 1 (get lst car*))
(test-equal '(2 3 4 5) (get lst cdr*))
(test-equal '(10 2 3 4 5)
(set lst car* 10)))
(test-group "Primitive lens composition"
(define lst '(1 2 3 4 5))
(test-equal 2 (get lst cadr*))
(test-equal '(1 10 3 4 5) (set lst cadr* 10)))
(test-group "Modify"
(define lst '(1 2 3 4 5))
(test-equal '(10 2 3 4 5) (modify lst car* (lambda (x) (* x 10))))
(test-equal '(1 20 3 4 5) (modify lst cadr* (lambda (x) (* x 10))))
)
(test-group "Modify*"
(define lst '(1 2 3 4 5))
(test-equal '(1 2 4 4 5)
(modify lst (lens-compose cdr* cdr* car*) 1+)))
(test-equal
"!e!l!,!W!r!d"
(list->string
(map cadr
(set (enumerate (string->list "Hello, World"))
(compose-lens
(focus-matching (compose even? car))
cdr*)
'(#\!)))))
(test-group "Identity lens"
(test-equal 'anything
(get 'anything identity-lens))
(test-equal 'else
(set 'anything identity-lens 'else))
(test-equal '(1 x 3)
(set '(1 2 3) (lens-compose cdr* identity-lens car*)
'x)))
'((hnh util lens))
|
