Define variables with name of structure fields. Use names instead positions as match-define

define-with-struct.rkt

#lang racket/base
;; ----------------------------------------------------------------------------
;;
;; Valeriya P.
;; https://gist.github.com/hww
;; _______ ________ ________
;; |   |   |  |  |  |  |  |  |
;; |       |  |  |  |  |  |  |
;; |___|___|________|________|
;;
;; ----------------------------------------------------------------------------

(require (for-syntax racket/base))
(require (for-syntax racket/syntax racket/base syntax/parse))

(provide define-with-struct define-with-struct-methods)

;; ----------------------------------------------------------------------------
;;
;; DEFINE WITH STRUCTURE FIELDS
;;
;; The main purpose - expand struct fields into local environment
;; definition. It allow to expand several structures with
;; prefix.
;;
;; (define-struct v3 (x y z))
;; (define va (v3 1 2 3))
;; (define vb (v3 4 5 6))
;;
;; (define/contract (v3-compare-xy this other)
;;   (define-with-struct lhs. (v3 x y) this)
;;   (define-with-struct rhs. (v3 x y) other)
;;   (and (equal? lhs.x rhs.x)
;;        (equal? lhs.y rhs.y)))
;;
;; ----------------------------------------------------------------------------

(define-syntax (define-with-struct stx)
  (syntax-parse stx
    [(_ (type:id arg0:id ...) obj)
     (define get-args (for/list ([arg (syntax->list #'(arg0 ...))]) (list arg (format-id stx "~a-~a" #'type arg))))
     (with-syntax ((((n get-arg) ...) get-args))
       (syntax/loc stx
         (begin (define n (get-arg obj)) ...)))]
    [(_ prefix:id (type:id arg0:id ...) obj)
     (define get-args (for/list ([arg (syntax->list #'(arg0 ...))]) (list (format-id stx "~a~a" #'prefix arg) (format-id stx "~a-~a" #'type arg))))
     (with-syntax ((((n get-arg) ...) get-args))
       (syntax/loc stx
         (begin (define n (get-arg obj)) ...)))]))

(module+ test
  (require rackunit)
  ;; Define the vector 2 structure
  (define-struct v2 (x y) #:transparent #:mutable)
  ;; Define the quaternion structure
  (define-struct (quat v2) (z w) #:transparent #:mutable)
  ;; Define quaternion value
  (let ((q (quat 1 2 3 4)))
    ;; Define fields of quaternion
    (define-with-struct (quat z w) q)
    (check-equal? z 3)
    (check-equal? w 4)
    ;; Define fields of quaternion with prefix
    (define-with-struct a. (quat z w) q)
    (check-equal? a.z 3)
    (check-equal? a.w 4)
    (define (foo)
      (define-with-struct f. (v2 x y) (v2 1 2)) (+ f.x f.y))
    (check-equal? (foo) 3)))


;; ----------------------------------------------------------------------------
;;
;; DEFINE WITH STRUCTURE FIELDS GETTERS AND SETTER
;;
;; The main purpose - expand struct fields into getters and setters
;;
;; (define-struct v3 (x y z))
;; (define v (v3 1 2 3))
;;
;; (define-with-struct-methods (v3 x y))
;; (set-x! v 10)
;; (x v) ;; -> 10
;;
;; (define-with-struct m- (v3 x y))
;; (set-m-x! v 10)
;; (m-x v) ;; -> 10
;;
;; Another way is used for the structures composition. 
;; First make composition with v3
;; (define-struct v4 (v w))
;; (define v-obj (v4 (v3 1 2 3) 4) ; make the object
;; Define methds x y for v4 the last parameter is getter for v3 field
;; (define-with-struct v4- (v3 x y) v4-v) 
;; Now
;; (set-v4-x! v-obj 50)
;; (v4-x v-obj) ;; -> 50
;; ----------------------------------------------------------------------------

(define-syntax (define-with-struct-methods stx)
  (syntax-parse stx
    [(_ (type:id arg0:id ...) (~optional method))
     (define get-args (for/list ([arg (syntax->list #'(arg0 ...))])
                        (list arg
                              (format-id stx "set-~a!" arg)
                              (format-id stx "~a-~a" #'type arg)
                              (format-id stx "set-~a-~a!" #'type arg))))
     (with-syntax ((((getter setter get-arg set-arg) ...) get-args))
       (syntax/loc stx
         (begin
           (begin (define (getter obj) (get-arg (~? (~@ (method obj)) (~@ obj))))
                  (define (setter obj val) (set-arg (~? (~@ (method obj)) (~@ obj)) val))) ...)))]
    [(_ prefix:id (type:id arg0:id ...) (~optional method))
     (define get-args (for/list ([arg (syntax->list #'(arg0 ...))])
                        (list
                         (format-id stx "~a~a" #'prefix arg)
                         (format-id stx "set-~a~a!" #'prefix arg)
                         (format-id stx "~a-~a" #'type arg)
                         (format-id stx "set-~a-~a!" #'type arg))))
     (with-syntax ((((getter setter get-arg set-arg) ...) get-args))
       (syntax/loc stx
         (begin
           (begin
             (define (getter obj) (get-arg (~? (~@ (method obj)) (~@ obj))))
             (define (setter obj val) (set-arg (~? (~@ (method obj)) (~@ obj)) val))) ...)))]))

(module+ test
  (require rackunit)
  (let ((q (quat 1 2 3 4)))
    ;; Define fields of quaternion
    (define-with-struct-methods (quat z w) )
    (check-equal? (z q) 3)
    (check-equal? (w q) 4)
    (set-z! q 2)
    (check-equal? (z q) 2)
    ;; Define fields of quaternion with prefix
    (define-with-struct-methods a- (quat z w))
    (check-equal? (a-z q) 2)
    (check-equal? (a-w q) 4)
    (set-a-w! q 5)
    (check-equal? (a-w q) 5)
    ;; Define with fields of composition
    (define-struct composed (s))
    (define composed-obj (composed (quat 1 2 3 4)))
    (define-with-struct-methods composed- (quat z w) composed-s)
    (set-composed-z! composed-obj 100)
    (check-equal? (composed-z composed-obj) 100)
    ))