Skip to content

Instantly share code, notes, and snippets.

@ruliana
Created September 25, 2021 02:50
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save ruliana/a06571dcef68c67341718424c14a5a22 to your computer and use it in GitHub Desktop.
Save ruliana/a06571dcef68c67341718424c14a5a22 to your computer and use it in GitHub Desktop.
Experiment expanding the basic nature of Racket structs to allow reflection and dynamic reference to fields. Also, use the struct as a procedure for get and set.
#lang racket
(require
racket/generic
(for-syntax racket/syntax
racket/function
syntax/parse
syntax/parse/define))
(provide struct*
fields name get set)
(module+ test
(require rackunit))
(define-generics reflective-struct
(fields reflective-struct)
(name reflective-struct)
(get reflective-struct . field-symbol)
(set reflective-struct field-symbol value))
(define-syntax (struct* stx)
(syntax-parse stx
[(_ struct-name:id [struct-prop:id ...] extra-properties ...)
(define (getter-name prop-stx) (format-id prop-stx "~a-~a" #'struct-name prop-stx))
(with-syntax ([orig stx]
[(full-prop-name ...)
(map getter-name (syntax->list #'(struct-prop ...)))]
[(struct-properties ...)
(filter identity
(list
(if (member '#:opaque (syntax->datum #'(extra-properties ...))) #f '#:transparent)))])
#'(begin
(define-struct/derived orig struct-name [struct-prop ...]
struct-properties ...
;; TODO Create this one if none is provided in "extra-properties"
#:property prop:procedure
(case-lambda
[(power-struct field-symbol) (get power-struct field-symbol)]
[(power-struct field-symbol value) (set power-struct field-symbol value)])
#:methods gen:reflective-struct
[(define (fields power-struct) '(struct-prop ...))
(define (name power-struct) 'struct-name)
(define/match (get power-struct . field-symbol)
[(obj (list 'struct-prop)) (full-prop-name obj)] ...
[(obj (list field-symbol* ..2)) (map (λ (e) (get obj e)) field-symbol*)]
[(obj _) (raise-syntax-error
#f
(format "Field '~a' is not a field of '~a'. Fields are '~a'"
field-symbol
'struct-name
'(struct-prop ...))
#'orig)])
(define/match (set power-struct field-symbol value)
[(obj 'struct-prop v) (struct-copy struct-name obj [struct-prop v])] ...
[(obj _ _) (raise-syntax-error
#f
(format "Field '~a' is not a field of '~a'. Fields are '~a'"
field-symbol
'struct-name
'(struct-prop ...))
#'orig)])])))]))
(module+ test
(struct* test1 [a b])
(struct* test2 [a b c] #:opaque)
(define x (test1 1 2))
(define y (test2 3 4 5))
(check-equal? x (test1 1 2))
(check-not-equal? x (test1 1 3))
(check-equal? y y)
(check-not-equal? y (test2 3 4 5))
(check-equal? (name x) 'test1)
(check-equal? (name y) 'test2)
(check-equal? (fields x) '(a b))
(check-equal? (fields y) '(a b c))
; Getters
(check-equal? (get x 'b) 2)
(check-equal? (x 'b) 2)
(check-equal? (get y 'b) 4)
(check-equal? (y 'b) 4)
(check-equal? (get y 'c 'b 'a) (list 5 4 3))
; Immutable setters
(check-equal? (set x 'a 10) (test1 10 2))
(check-equal? (x 'a 10) (test1 10 2)))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment