blob: 5932cce638e43e24d69aceef45c3d1bea6e72c30 (
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
78
79
80
81
82
|
(define-module (hnh util lens)
:use-module (srfi srfi-1)
:use-module (ice-9 control)
:use-module (ice-9 curried-definitions)
:export (modify
set
get
identity-lens
compose-lens
lens-compose
focus-matching
traversed
ref car* cdr*
))
(define ((car* lst) f)
(cons (f (car lst)) ; ← focus
(cdr lst)))
(define ((cdr* lst) f)
(cons (car lst)
(f (cdr lst))))
(define (((ref idx) list) f)
(let loop ((idx idx) (rem list))
(if (zero? idx)
(cons (f (car rem))
(cdr rem))
(cons (car rem)
(loop (1- idx)
(cdr rem))))))
(define (((focus-matching predicate) list) f)
(map (lambda (x)
(if (predicate x)
(f x)
x))
list))
;;; Lens l i :: l i → (i → i) → l i
;;; modify :: (l i, Lens l i, (i → i)) → l i
(define (modify container lens f)
((lens container) f))
;;; set :: (l i, Lens l i, i) → l i
(define (set container lens value)
(modify container lens (const value)))
;;; get :: (l i, Lens l i) → i
(define (get container lens)
(call/ec (lambda (return)
(modify container lens return))))
(define (traversed container lens)
(define v '())
((lens container) (lambda (x) (set! v (cons x v))))
v)
(define lens-compose
(case-lambda
((lens)
(lambda (object)
(lambda (operator)
(modify object lens operator))))
((lens . lenses)
(lambda (object)
(lambda (operator)
(modify object lens
(lambda (focus) (((apply lens-compose lenses) focus) operator))))))))
(define compose-lens lens-compose)
(define ((identity-lens object) op)
(op object))
|
