Add reader macro for struct reference

1 files changed, 25 insertions, 6 deletions

diff --git a/weeb/struct.scm b/weeb/struct.scm
index fbf90c3..c3632f4 100644
--- a/weeb/struct.scm
+++ b/weeb/struct.scm
@@ -17,12 +17,14 @@
 ;;; 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))
+            call-with-slots
+            ref))
 
 ;; Define a new record type with the given NAME and FIELDS.
 (define-syntax define-struct
@@ -46,8 +48,6 @@ instantiate the record's fields."
   (and (record? rtd)
        ((record-predicate type) rtd)))
 
-;; Bind the accessors for the fields of the record RTD to local
-;; variables in BODY. RTD must be a record type descriptor.
 (define-syntax with-accessors
   (syntax-rules ()
     ((with-accessors (rtd field ...)
@@ -57,9 +57,6 @@ instantiate the record's fields."
              ...)
          body ...)))))
 
-;; Bind the slots of the record RTD to the named variables in LAMBDA.
-;; This allows for pattern-matching-like access to the fields of the
-;; record.
 (define-syntax call-with-slots
   (syntax-rules ()
     ((call-with-slots rtd
@@ -69,3 +66,25 @@ instantiate the record's fields."
        (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)))))))