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
|
;;; kaakaa --- Tiny, security-focused AI agent in Guile
;;; Copyright © 2026 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of kaakaa.
;;;
;;; kaakaa is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; kaakaa is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with kaakaa. If not, see <https://www.gnu.org/licenses/>.
(define-module (kaakaa records)
#:use-module (rnrs records procedural)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 match)
#:use-module (lens)
#:export (define-record-type*
define-public-record-type*))
(define (make-record-type* record-name make-constructor . fields)
"Create a record type with @var{record-name} and @var{fields}.
@var{make-constructor} is a function that is passed a basic record constructor
accepting positional arguments and must return the record constructor. Return
@code{length(fields) + 3} values---the record type descriptor, the record
constructor, the record predicate and the field accessors.
@var{fields} is a list of field specifiers each of which is of the form
@code{(field-name accessor-type)}. @var{accessor-type} is either
@code{'accessor} or @code{'lensed}."
(let* ((rtd (make-record-type-descriptor record-name #f #f #f #f
(list->vector (map (match-lambda
((field-name _)
field-name))
fields))))
(constructor (record-constructor
(make-record-constructor-descriptor rtd #f #f)))
(accessors (map (cut record-accessor rtd <>)
(iota (length fields)))))
(apply values
rtd
(make-constructor constructor)
(record-predicate rtd)
(map (match-lambda*
((_ accessor (_ 'accessor))
accessor)
((index accessor (_ 'lensed))
(lens accessor
(lambda (record proc)
(apply constructor
(append (map (lambda (accessor)
(accessor record))
(take accessors index))
(list (proc ((list-ref accessors index)
record)))
(map (lambda (accessor)
(accessor record))
(drop accessors (1+ index)))))))))
(iota (length fields))
accessors
fields))))
(define-syntax define-record-type*
(lambda (x)
"Define a record type. All fields are immutable and may optionally have lenses as
accessors.
Lenses are procedures that combine getters and setters into one structure. They
allow you to conveniently manipulate parts of deeply nested data structures in a
composable and purely functional way.
Consider the following example record definition:
@example
(define-record-type* (<employee> employee employee?)
(name employee-name)
(age employee-age lensed)
(salary employee-salary lensed))
@end example
In this example, @code{employee-name} is a regular accessor, while
@code{employee-age} and @code{employee-salary} are lenses.
@code{employee-name} is a regular accessor. Get with:
@example
(employee-name x)
@end example
@code{employee-age} is a lens. Get with:
@example
(focus employee-age x)
@end example
Functionally update with:
@example
(put employee-age 25 x)
@end example
Record definitions may also optionally specify a @code{make-constructor}
argument which is passed to @code{make-record-type*}. For example:
@example
(define-record-type* (<employee> employee employee?)
(lambda (constructor)
(lambda* (name #:key age salary)
(constructor name age salary)))
(fields (name employee-name)
(age employee-age lensed)
(salary employee-salary lensed)))
@end example
"
(syntax-case x (fields)
((_ (record-name constructor-name predicate-name)
make-constructor
(fields field-spec ...))
#`(define-values (record-name constructor-name predicate-name
#,@(map (lambda (x)
(syntax-case x ()
((_ accessor-name _ ...)
#'accessor-name)))
#'(field-spec ...)))
(make-record-type* 'record-name
make-constructor
#,@(map (lambda (x)
(syntax-case x (lensed)
((field-name accessor-name)
#''(field-name accessor))
((field-name accessor-name lensed)
#''(field-name lensed))))
#'(field-spec ...)))
))
((_ (record-name constructor-name predicate-name)
(fields field-spec ...))
#'(define-record-type* (record-name constructor-name predicate-name)
identity
(fields field-spec ...))))))
(define-syntax define-public-record-type*
(lambda (x)
"Like @code{define-record-type*}, but also export the constructor, the predicate
and the accessors."
(syntax-case x (fields)
((_ (record-name constructor-name predicate-name)
make-constructor
(fields field-spec ...))
#`(begin
(define-record-type* (record-name constructor-name predicate-name)
make-constructor
(fields field-spec ...))
(export constructor-name)
(export predicate-name)
#,@(map (lambda (x)
(syntax-case x ()
((_ accessor-name _ ...)
#'(export accessor-name))))
#'(field-spec ...))))
((_ (record-name constructor-name predicate-name)
(fields field-spec ...))
#'(define-public-record-type* (record-name constructor-name predicate-name)
identity
(fields field-spec ...))))))
|
