blob: c3632f4b0a0d6c4dab4e0e4114d878e172467200 (
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
83
84
85
86
87
88
89
90
|
;;; Weeb --- Web microframework for GNU Guile
;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This file is part of Weeb.
;;;
;;; Weeb is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Weeb 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 Affero General
;;; Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.
(define-module (weeb struct)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:export (define-struct
make-struct
instance-of?
with-accessors
call-with-slots
ref))
;; Define a new record type with the given NAME and FIELDS.
(define-syntax define-struct
(lambda (stx)
(syntax-case stx ()
((_ name field* ...)
#'(define name
(let* ((type-string (symbol->string (quote name)))
(type-representation (match:substring
(string-match "[^<> ]+" type-string))))
(make-record-type (quote name)
(quote (field* ...)))))))))
(define (make-struct type . args)
"Create a new instance of the record type TYPE using ARGS to
instantiate the record's fields."
(apply (record-constructor type) args))
(define (instance-of? rtd type)
"Returns true if RTD is an instance of TYPE."
(and (record? rtd)
((record-predicate type) rtd)))
(define-syntax with-accessors
(syntax-rules ()
((with-accessors (rtd field ...)
body ...)
(let ((rtd-eval rtd))
(let ((field ((record-accessor (record-type-descriptor rtd) 'field) rtd))
...)
body ...)))))
(define-syntax call-with-slots
(syntax-rules ()
((call-with-slots rtd
(lambda (field ...)
body ...))
(let ((rtd-eval rtd))
(let ((field ((record-accessor (record-type-descriptor rtd) 'field) rtd))
...)
body ...)))))
(define* (ref obj #:rest keys)
(match keys
(() obj)
((key rest ...)
(if (or (not (record? obj))
(not (record-accessor (record-type-descriptor obj) key)))
#f
(apply ref
((record-accessor (record-type-descriptor obj) key) obj)
rest)))))
(read-hash-extend #\.
(lambda (chr port)
(let* ((sym (read port))
(str (symbol->string sym))
(parts (string-split str #\.)))
(let ((symbols (map string->symbol parts)))
(let ((base-obj (car symbols))
(fields (cdr symbols)))
(let ((quoted-fields (map (lambda (f) `',f) fields)))
`(ref ,base-obj ,@quoted-fields)))))))
|
© 2015 - 2026 Jakob L. Kreuze
