36 lines
1.1 KiB
Racket
36 lines
1.1 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base))
|
|
|
|
(provide define-struct/reg-mk
|
|
id->constructor
|
|
(struct-out point)
|
|
(struct-out bb))
|
|
|
|
(define id-constructor-pairs '())
|
|
(define (add-id-constructor-pair a b)
|
|
(set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
|
|
|
|
(define-syntax (define-struct/reg-mk stx)
|
|
(syntax-case stx ()
|
|
[(_ id #:reflect-id reflect-id rest ...)
|
|
(let ([build-name
|
|
(λ (fmt id)
|
|
(datum->syntax id (string->symbol (format fmt (syntax->datum id)))))])
|
|
#`(begin
|
|
(define-struct id rest ... #:reflection-name 'reflect-id)
|
|
(add-id-constructor-pair '#,(build-name "struct:~a" #'reflect-id)
|
|
#,(build-name "make-~a" #'id))))]
|
|
[(_ id . rest) #'(define-struct/reg-mk id #:reflect-id id . rest)]))
|
|
|
|
(define (id->constructor id)
|
|
(let ([line (assoc id id-constructor-pairs)])
|
|
(and line
|
|
(list-ref line 1))))
|
|
|
|
(define-struct/reg-mk point (x y) #:transparent)
|
|
|
|
;; a bb is (bounding box)
|
|
;; (make-bb number number number)
|
|
(define-struct/reg-mk bb (right bottom baseline) #:transparent)
|